Changeset 13480 in project for release/4/synch


Ignore:
Timestamp:
03/04/09 02:07:27 (11 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • release/4/synch/trunk/synch.scm

    r13474 r13480  
    7070;;;
    7171
     72(define-for-syntax (recmuxnam nam)
     73  (string->symbol (conc nam #\- 'mutex)) )
     74
     75;;;
     76
    7277(define (make-object/synch obj #!optional (name '(synchobj)))
    7378  (let ([mutex (make-mutex (if (pair? name) (gensym (car name)) name))])
    … …  
    108113          [$mutex-unlock! (r 'mutex-unlock!)]
    109114          [$mutex-specific (r 'mutex-specific)]
    110           [$mutex-lock! (r 'mutex-lock!)])
    111       (let ([mtxvar (gensym)]
    112             [?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)])
     115          [$mutex-lock! (r 'mutex-lock!)]
     116          [mtxvar (r (gensym))])
     117      (let ([?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)])
    113118                    `(,$let ([,mtxvar ,?mtx])
    114119           (,$let ([,?var (,$mutex-specific ,mtxvar)])
    … …  
    175180          [$begin (r 'begin)])
    176181      (let ([?bnd (cadr form)] [?body (cddr form)])
    177         (let ([?var (car ?bnd)]
    178               [?mtx (cadr ?bnd)])
     182        (let ([?var (car ?bnd)] [?mtx (cadr ?bnd)])
    179183          `(,$synch-with ,?mtx ,?var
    180184             (,$mutex-specific-set! ,?mtx (,$begin ,@?body))
    181185             (,$mutex-specific ,?mtx) ) ) ) ) ) )
    182186
     187#; ;Since not capturing anything shouldn't need to do this
    183188(define-syntax synch/lock
     189  (lambda (form r c)
     190    (##sys#check-syntax 'synch/lock form '(_ _ . _))
     191    (let ([$dynamic-wind (r 'dynamic-wind)]
     192          [$unless (r 'unless)]
     193          [$begin (r 'begin)]
     194          [$let (r 'let)]
     195          [$set! (r 'set!)]
     196          [$lambda (r 'lambda)]
     197          [$mutex-unlock! (r 'mutex-unlock!)]
     198          [$mutex-specific (r 'mutex-specific)]
     199          [$mutex-lock! (r 'mutex-lock!)]
     200          [mtxvar (r (gensym))]
     201          [okvar (r (gensym))]
     202          [resvar (r (gensym))])
     203      (let ([?mtx (cadr form)] [?body (cddr form)])
     204        `(,$let ([,mtxvar ,?mtx] [,okvar #f])
     205           (,$dynamic-wind
     206             (,$lambda () (,$mutex-lock! ,mtxvar))
     207             (,$lambda () (,$let ([,resvar (,$begin ,@?body)]) (,$set! ,okvar #t) ,resvar))
     208             (,$lambda () (,$unless ,okvar (,$mutex-unlock! ,mtxvar))) ) ) ) ) ) )
     209
     210(define-syntax synch/lock
    184211        (syntax-rules ()
    185212                [(_ ?mtx ?body ...)
    186213                  (let ([mtx ?mtx] [ok? #f])
    187                           (dynamic-wind
     214                                (mutex-lock! mtx)
     215                                (dynamic-wind
    188216                                  (lambda () (mutex-lock! mtx))
    189                                   (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res))
    190                                   (lambda () (unless ok? (mutex-unlock! mtx))) ) ) ] ) )
     217                                        (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res))
     218                                        (lambda () (unless ok? (mutex-unlock! mtx)))) ) ] ) )
    191219
    192220(define-syntax synch/unlock
    … …  
    205233  (lambda (form r c)
    206234    (##sys#check-syntax 'object/synch form '(_ _ . _))
    207 
    208         (syntax-rules ()
    209                 [(_ ?mtx ?body ...) ] ) )
    210         (let ([?var (gensym)])
    211                 (let body-loop ([unparsed BODY] [PARSED '()])
    212                         (cond [(null? unparsed)
    213                                                         `(synch-with ?mtx ,?var ,@(reverse PARSED))]
    214                                                 [(pair? unparsed)
    215                                                         (let ([expr (car unparsed)]
    216                                                                                 [next (cdr unparsed)])
    217                                                                 (let expr-loop ([rest expr] [EXPR '()])
    218                                                                         (cond [(null? rest)
    219                                                                                                         (body-loop next (cons (reverse EXPR) PARSED))]
    220                                                                                                 [(pair? rest)
    221                                                                                                         (let ([arg (car rest)]
    222                                                                                                                                 [next (cdr rest)])
    223                                                                                                                 (if (eq? '>< arg)
    224                                                                                                                                 (expr-loop next (cons ?var EXPR))
    225                                                                                                                                 (expr-loop next (cons arg EXPR)) ) )]
    226                                                                                                 [(eq? '>< rest)
    227                                                                                                         (body-loop next (cons ?var PARSED))]
    228                                                                                                 [else
    229                                                                                                         (body-loop next (cons rest PARSED))] ) ) )]
    230                                                 [else
    231                                                         (syntax-error 'object/synch "invalid form?body ...)] ) ) ) )
     235    (let ([$synch-with (r 'synch-with)]
     236          [$>< (r '><)]
     237          [var (r (gensym))]
     238          [mtx (cadr form)])
     239      (let body-loop ([unparsed (cddr form)] [parsed '()])
     240        (if (not (null? unparsed))
     241            (let ([expr (car unparsed)]
     242                  [next (cdr unparsed)])
     243              (let expr-loop ([rest expr] [parsedexpr '()])
     244                (cond [(null? rest)
     245                        (body-loop next (cons (reverse parsedexpr) parsed))]
     246                      [(pair? rest)
     247                        (let ([arg (car rest)]
     248                              [next (cdr rest)])
     249                          (if (c $>< arg)
     250                              (expr-loop next (cons var parsedexpr))
     251                              (expr-loop next (cons arg parsedexpr)) ) )]
     252                      [(c $>< rest)
     253                        (body-loop next (cons var parsed))]
     254                      [else
     255                        (body-loop next (cons rest parsed))] ) ) )
     256            `(,$synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
    232257
    233258(define-syntax record/synch
    … …  
    236261    (let ([$synch (r 'synch)])
    237262      (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
    238         `(,$synch (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec) ,@?body) ) ) ) )
     263        `(,$synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    239264
    240265(define-syntax record-synch/lock
    … …  
    243268    (let ([$synch/lock (r 'synch/lock)])
    244269      (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
    245         `(,$synch/lock (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec) ,@?body) ) ) ) )
     270        `(,$synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    246271
    247272(define-syntax record-synch/unlock
    … …  
    250275    (let ([$synch/unlock (r 'synch/unlock)])
    251276      (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
    252         `(,$synch/unlock (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec) ,@?body) ) ) ) )
     277        `(,$synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    253278
    254279;;; Unprotected
    … …  
    266291
    267292(define-syntax %synch-mutex-with*
    268 
    269         (syntax-rules ()
    270                 [(_ ?mtx ?var ?body ...) ] ) )
    271         (let ([RET-?var (gensym)]
    272               [?mtx-?var (gensym 'mtx)])
    273                 `(let ([mtx ?mtx])
    274                          (let ([,?var (mutex-specific mtx)])
    275                                  (mutex-lock! mtx)
    276                                  (call-with-values
    277                                          (lambda () ?body ...)
    278                                          (lambda ret
    279                                                  (mutex-unlock! mtx)
    280                                                  (apply values ret))))) ) )
     293  (lambda (form r c)
     294    (##sys#check-syntax '%synch-mutex-with* form '(_ _ variable . _))
     295    (let ([$call-with-values (r 'call-with-values)]
     296          [$mutex-specific (r 'mutex-specific)]
     297          [$mutex-lock! (r 'mutex-lock!)]
     298          [$mutex-unlock! (r 'mutex-unlock!)]
     299          [$let (r 'let)]
     300          [$apply (r 'apply)]
     301          [$values (r 'values)]
     302          [$lambda (r 'lambda)]
     303          [$ret (r 'ret)]
     304          [mtxvar (r (gensym))])
     305      (let ([?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)])
     306        `(,$let ([,mtxvar ,?mtx])
     307           (,$let ([,?var (,$mutex-specific ,mtxvar)])
     308             (,$mutex-lock! ,mtxvar)
     309             (,$call-with-values
     310               (,$lambda () ,@?body)
     311               (,$lambda ,$ret
     312                 (,$mutex-unlock! ,mtxvar)
     313                 (,$apply ,$values ,$ret)) ) ) ) ) ) ) )
    281314
    282315(define-syntax %synch
    … …  
    305338
    306339(define-syntax %let/synch
    307 
    308         (syntax-rules ()
    309                 [(_ BINDINGS ?body ...) ] ) )
    310         (car (let loop ([bnds BINDINGS])
    311          (cond [(null? bnds)
    312                ?body ...]
    313                [(pair? (car bnds))
    314                  (let ([bnd (car bnds)])
    315                    (if (pair? bnd)
    316                        `((%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr bnds))))
    317                        (syntax-error '%let/synch "invalid binding form" bnd) ) )]
    318                [else
    319                  (syntax-error '%let/synch "invalid binding form" bnds)] ) )) )
     340  (lambda (form r c)
     341    (##sys#check-syntax '%let/synch form '(_ list . _))
     342    (let ([$%synch-with (r '%synch-with)])
     343      (let ([?body (cddr form)])
     344        (car
     345          (let loop ([?bnds (cadr form)])
     346            (if (not (null? ?bnds))
     347                (let ([bnd (car ?bnds)])
     348                  (##sys#check-syntax '%let/synch bnd '(variable _))
     349                  `((,$%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
     350                ?body ) ) ) ) ) ) )
    320351
    321352(define-syntax %set!/synch
    322 
    323         (syntax-rules ()
    324                 [(_ ?binding . ?body) ] ) )
    325         (if (pair? ?binding)
    326                         (let ([?var (car ?binding)]
    327                                                 [?mutex (cadr ?binding)])
    328                                 `(%synch-with ,?mutex ,?var
    329                                          (mutex-specific-set! ,?mutex (begin ,@?body))
    330                                          (mutex-specific ,?mutex) ) )
    331                         (syntax-error '%set!/synch "invalid binding form" ?binding) ) )
     353  (lambda (form r c)
     354    (##sys#check-syntax '%set!/synch form '(_ pair . _))
     355    (let ([$%synch-with (r '%synch-with)]
     356          [$mutex-specific (r 'mutex-specific)]
     357          [$mutex-specific-set! (r 'mutex-specific-set!)]
     358          [$let (r 'let)]
     359          [$begin (r 'begin)]
     360          [mtxvar (r (gensym))])
     361      (let ([?bnd (cadr form)] [?body (cddr form)])
     362        (let ([?var (car ?bnd)] [?mtx (cadr ?bnd)])
     363          `(,$let ([,mtxvar ,?mtx])
     364             (,$%synch-with ,mtxvar ,?var
     365               (,$mutex-specific-set! ,mtxvar (,$begin ,@?body))
     366               (,$mutex-specific ,mtxvar) ) ) ) ) ) ) )
    332367
    333368(define-syntax %synch/lock
    334 
    335         (syntax-rules ()
    336                 [(_ ?mtx ?body ...) ] ) )
    337         (let ([RET-?var (gensym)] [?mtx-?var (gensym 'mtx)] [OK-?var (gensym)] [RES-?var (gensym)])
    338                 `(let ([mtx ?mtx] [ok? #f])
    339                         (begin
     369        (syntax-rules ()
     370                [(_ ?mtx ?body ...)
     371                  (let ([mtx ?mtx] [ok? #f])
    340372                                (mutex-lock! mtx)
    341373                                (call-with-values
    … …  
    343375                                        (lambda ret
    344376                                                (unless ok? (mutex-unlock! mtx))
    345                                                 (apply values ret))) ) ) ) )
     377                                                (apply values ret))) ) ] ) )
    346378
    347379(define-syntax %synch/unlock
    348 
    349         (syntax-rules ()
    350                 [(_ ?mtx ?body ...) ] ) )
    351         (let ([RET-?var (gensym)] [?mtx-?var (gensym 'mtx)])
    352                 `(let ([mtx ?mtx])
    353                          (begin
    354                                  (unless (thread? (mutex-state mtx))
    355                                          (warning '%synch/unlock "mutex is not locked")
    356                                          (mutex-lock! mtx))
    357                                  (call-with-values
    358                                          (lambda () ?body ...)
    359                                          (lambda ret
    360                                                  (mutex-unlock! mtx)
    361                                                  (apply values ret)) ) ) ) ) )
     380        (syntax-rules ()
     381                [(_ ?mtx ?body ...)
     382      (let ([mtx ?mtx])
     383        (unless (thread? (mutex-state mtx))
     384          (warning '%synch/unlock "mutex is not locked - locking")
     385          (mutex-lock! mtx))
     386        (call-with-values
     387          (lambda () ?body ...)
     388          (lambda ret
     389            (mutex-unlock! mtx)
     390            (apply values ret)) ) ) ] ) )
    362391
    363392(define-syntax %object/synch
    364 
    365         (syntax-rules ()
    366                 [(_ ?mtx ?body ...) ] ) )
    367         (let ([?var (gensym)])
    368                 (let body-loop ([unparsed BODY] [PARSED '()])
    369                         (cond [(null? unparsed)
    370                                                         `(%synch-with ?mtx ,?var ,@(reverse PARSED))]
    371                                                 [(pair? unparsed)
    372                                                         (let ([expr (car unparsed)]
    373                                                                                 [next (cdr unparsed)])
    374                                                                 (let expr-loop ([rest expr] [EXPR '()])
    375                                                                         (cond [(null? rest)
    376                                                                                                         (body-loop next (cons (reverse EXPR) PARSED))]
    377                                                                                                 [(pair? rest)
    378                                                                                                         (let ([arg (car rest)]
    379                                                                                                                                 [next (cdr rest)])
    380                                                                                                                 (if (eq? '>< arg)
    381                                                                                                                                 (expr-loop next (cons ?var EXPR))
    382                                                                                                                                 (expr-loop next (cons arg EXPR)) ) )]
    383                                                                                                 [(eq? '>< rest)
    384                                                                                                         (body-loop next (cons ?var PARSED))]
    385                                                                                                 [else
    386                                                                                                         (body-loop next (cons rest PARSED))] ) ) )]
    387                                                 [else
    388                                                         (syntax-error 'object/synch "invalid form?body ...)] ) ) ) )
     393  (lambda (form r c)
     394    (##sys#check-syntax '%object/synch form '(_ _ . _))
     395    (let ([$%synch-with (r '%synch-with)]
     396          [$>< (r '><)]
     397          [var (r (gensym))]
     398          [mtx (cadr form)])
     399      (let body-loop ([unparsed (cddr form)] [parsed '()])
     400        (if (not (null? unparsed))
     401            (let ([expr (car unparsed)]
     402                  [next (cdr unparsed)])
     403              (let expr-loop ([rest expr] [parsedexpr '()])
     404                (cond [(null? rest)
     405                        (body-loop next (cons (reverse parsedexpr) parsed))]
     406                      [(pair? rest)
     407                        (let ([arg (car rest)]
     408                              [next (cdr rest)])
     409                          (if (c $>< arg)
     410                              (expr-loop next (cons var parsedexpr))
     411                              (expr-loop next (cons arg parsedexpr)) ) )]
     412                      [(c $>< rest)
     413                        (body-loop next (cons var parsed))]
     414                      [else
     415                        (body-loop next (cons rest parsed))] ) ) )
     416            `(,$%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
    389417
    390418(define-syntax %record/synch
    391419  (lambda (form r c)
    392     (##sys#check-syntax 'object/synch form '(_ _ . _))
    393 
    394         (syntax-rules ()
    395                 [(_ ?sym ?rec ?body ...) ] ) )
    396         `(%synch (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec)
    397                 ?body ...) )
     420    (##sys#check-syntax '%record/synch form '(_ variable _ . _))
     421    (let ([$%synch (r '%synch)])
     422      (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     423        `(,$%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) )
    398424
    399425(define-syntax %record-synch/lock
    400426  (lambda (form r c)
    401     (##sys#check-syntax 'object/synch form '(_ _ . _))
    402 
    403         (syntax-rules ()
    404                 [(_ ?sym ?rec ?body ...) ] ) )
    405         `(%synch/lock (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec)
    406                 ?body ...) )
     427    (##sys#check-syntax '%record-synch/lock form '(_ variable _ . _))
     428    (let ([$%synch/lock (r '%synch/lock)])
     429      (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     430        `(,$%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    407431
    408432(define-syntax %record-synch/unlock
    409433  (lambda (form r c)
    410     (##sys#check-syntax 'object/synch form '(_ _ . _))
    411 
    412         (syntax-rules ()
    413                 [(_ ?sym ?rec ?body ...)
    414                   (%synch/unlock (,(string->symbol (conc ?sym #\- 'mutex)) ?rec)
    415                     ?body ...) ] ) )
     434    (##sys#check-syntax '%record-synch/unlock form '(_ variable _ . _))
     435    (let ([$%synch/unlock (r '%synch/unlock)])
     436      (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     437        `(,$%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    416438
    417439) ;module synch
Note: See TracChangeset for help on using the changeset viewer.