Changeset 36962 in project


Ignore:
Timestamp:
12/03/18 17:52:13 (10 days ago)
Author:
kon
Message:

reduce clutter

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

Legend:

Unmodified
Added
Removed
  • release/5/synch/trunk/critical-region.scm

    r36958 r36962  
    226226  (%critical-region (thunk)) )
    227227
    228 ;;;
    229 
    230228) ;module critical-region
  • release/5/synch/trunk/format-synch.scm

    r36034 r36962  
    88
    99(import scheme
    10   (rename (chicken format) (format original-format))
     10  (rename format (format egg-format))
    1111  (only synch synchronized-procedure))
    1212
    13 (define format (synchronized-procedure original-format))
     13(define format (synchronized-procedure egg-format))
    1414
    1515) ;format-synch
  • release/5/synch/trunk/synch.egg

    r36945 r36962  
    1212 (test-dependencies test miscmacros)
    1313 (components
     14  #; ;doesn't exist
    1415  (cond-expand
    1516    (expose-critical-region
  • release/5/synch/trunk/synch.scm

    r36034 r36962  
    77;;
    88;; - syntax checking is minimal so expansion errors are cryptic
     9;;
     10;; - dynamic-wind, ...
    911
    1012(module synch
     
    6466;;;
    6567
    66 (define-for-syntax (record-mutex-name nam)
    67   (string->symbol (string-append (symbol->string nam) "-" "mutex")) )
     68(define-for-syntax (suffix-symbol sym suf)
     69  (string->symbol (string-append (symbol->string sym) "-" suf)) )
    6870
    6971;;; Protected
     72
     73(define-syntax dynwnd-wrap
     74        (syntax-rules ()
     75          ((dynwnd-wrap ?mtx (?lock-arg0 ...) (?unlock-arg0 ...) ?body ...)
     76      (dynamic-wind
     77        (lambda () (mutex-lock! ?mtx ?lock-arg0 ...))
     78        (lambda () ?body ...)
     79        (lambda () (mutex-unlock! ?mtx ?unlock-arg0 ...)) ) ) ) )
    7080
    7181;;
     
    7686                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
    7787        (let ((mtx ?mtx))
    78         (dynamic-wind
    79           (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    80           (lambda () ?body ...)
    81           (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     88        (dynwnd-wrap mtx (?lock-arg0 ...) (?unlock-arg0 ...)
     89          ?body ...) ) )
    8290    ;
    8391                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
     
    92100  (er-macro-transformer
    93101    (lambda (frm rnm cmp)
    94       ;
    95102      (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
    96       ;
    97103      (let (
    98104        (_dynamic-wind (rnm 'dynamic-wind) )
     
    103109        (_mutex-lock! (rnm 'mutex-lock!) )
    104110        (mtxvar (rnm (gensym)) ) )
    105         ;
    106111        (let (
    107112          (?mtx (cadr frm) )
    108113          (?var (caddr frm) )
    109114          (?body (cdddr frm) ) )
    110           ;
    111115          (call-with-values
    112116            (lambda ()
    113117              (if (not (pair? ?mtx))
    114118                (values ?mtx '() '())
    115                 (let ((mtx (car ?mtx))
    116                       (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    117                       (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     119                (let (
     120                  (mtx (car ?mtx))
     121                  (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     122                  (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    118123                  (values mtx lock-args unlock-args) ) ) )
    119124            (lambda (?mtx ?lock-args ?unlock-args)
     
    130135                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    131136                  (let ((mtx ?mtx))
    132                           (dynamic-wind
    133                                   (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    134                                   (lambda () (?proc ?arg0 ...))
    135                                   (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     137                          (dynwnd-wrap mtx (?lock-arg0 ...) (?unlock-arg0 ...)
     138                            (?proc ?arg0 ...)) ) )
    136139    ;
    137140                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     
    148151                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    149152                  (let ((mtx ?mtx))
    150                           (dynamic-wind
    151                                   (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    152                                   (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
    153                                   (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     153                          (dynwnd-wrap mtx (?lock-arg0 ...) (?unlock-arg0 ...)
     154                            (?proc (mutex-specific mtx) ?arg0 ...)) ) )
    154155    ;
    155156                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     
    163164(define-for-syntax apply-synch-transformer
    164165        (syntax-rules ()
     166          ;
    165167          ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    166168                  (let ((mtx ?mtx))
    167                           (dynamic-wind
    168                                   (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    169                                   (lambda () (apply ?proc ?arg0 ...))
    170                                   (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     169                          (dynwnd-wrap mtx (?lock-arg0 ...) (?unlock-arg0 ...)
     170                            (apply ?proc ?arg0 ...)) ) )
     171                ;
    171172          ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    172173                  (apply-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     
    182183                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    183184                  (let ((mtx ?mtx))
    184                           (dynamic-wind
    185                                   (lambda () (mutex-lock! mtx ?lock-arg0 ...))
    186                                   (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
    187                                   (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     185                          (dynwnd-wrap mtx (?lock-arg0 ...) (?unlock-arg0 ...)
     186                            (apply ?proc (mutex-specific mtx) ?arg0 ...)) ) )
    188187    ;
    189188                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
     
    198197  (er-macro-transformer
    199198    (lambda (frm rnm cmp)
    200       ;
    201199      (##sys#check-syntax 'let-synch-with frm '(_ list . _))
    202       ;
    203200      (let ((_synch-with (rnm 'synch-with)))
    204201        (let* (
     
    212209                  (##sys#check-syntax 'let-synch-with ?bnd '(variable . _))
    213210                  `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
    214           ;
    215211          (car res) ) ) ) ) )
    216212
     
    220216  (er-macro-transformer
    221217    (lambda (frm rnm cmp)
    222       ;
    223218      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
    224       ;
    225219      (let (
    226220        (_synch-with (rnm 'synch-with) )
     
    228222        (_mutex-specific-set! (rnm 'mutex-specific-set!) )
    229223        (_begin (rnm 'begin) ) )
    230         ;
    231224        (let (
    232225          (?mtx (cadr frm) )
    233226          (?var (caddr frm) )
    234227          (?body (cdddr frm) ) )
    235           ;
    236228          `(,_synch-with ,?mtx ,?var
    237229             (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
     
    279271  (er-macro-transformer
    280272    (lambda (frm rnm cmp)
    281       ;
    282273      (##sys#check-syntax 'object-synch-cut-with frm '(_ _ . _))
    283       ;
    284274      (let (
    285275        (_synch-with (rnm 'synch-with))
     
    287277        (var (rnm (gensym)))
    288278        (mtx (cadr frm)) )
    289         ;
    290279        (let body-loop ((unparsed (cddr frm)) (parsed '()))
    291280          (if (null? unparsed)
    292             ;
     281            ;code walked
    293282            `(,_synch-with ,mtx ,var ,@(reverse parsed))
    294             ;
     283            ;walk code
    295284            (let (
    296285              (expr (car unparsed))
    297286              (next (cdr unparsed)) )
    298               ;
    299287              (let expr-loop ((rest expr) (parsed-expr '()))
    300288                (cond
    301                   ;
    302289                  ((null? rest)
    303290                    (body-loop next (cons (reverse parsed-expr) parsed)))
    304                   ;
    305291                  ((pair? rest)
    306292                    (let (
    307293                      (arg (car rest))
    308294                      (next (cdr rest)) )
    309                       ;
    310295                      (if (cmp _>< arg)
    311296                        (expr-loop next (cons var parsed-expr))
    312297                        (expr-loop next (cons arg parsed-expr)) ) ))
    313                   ;
    314298                  ((cmp _>< rest)
    315299                    (body-loop next (cons var parsed)))
    316                   ;
    317300                  (else
    318301                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )
    319302
    320303(define-syntax object-synch-cut-with object-synch-cut-with-transformer)
     304
     305;;
     306
     307(define-for-syntax (record-mutex-name sym) (suffix-symbol sym "mutex"))
    321308
    322309;;
     
    390377    (lambda (frm rnm cmp)
    391378      (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
    392       (let ((_call-with-values (rnm 'call-with-values))
    393             (_mutex-specific (rnm 'mutex-specific))
    394             (_mutex-lock! (rnm 'mutex-lock!))
    395             (_mutex-unlock! (rnm 'mutex-unlock!))
    396             (_let (rnm 'let))
    397             (_apply (rnm 'apply))
    398             (_values (rnm 'values))
    399             (_lambda (rnm 'lambda))
    400             (_ret (rnm 'ret))
    401             (mtxvar (rnm (gensym))))
    402         (let ((?mtx (cadr frm))
    403               (?var (caddr frm))
    404               (?body (cdddr frm)))
     379      (let (
     380        (_call-with-values (rnm 'call-with-values))
     381        (_mutex-specific (rnm 'mutex-specific))
     382        (_mutex-lock! (rnm 'mutex-lock!))
     383        (_mutex-unlock! (rnm 'mutex-unlock!))
     384        (_let (rnm 'let))
     385        (_apply (rnm 'apply))
     386        (_values (rnm 'values))
     387        (_lambda (rnm 'lambda))
     388        (_ret (rnm 'ret))
     389        (mtxvar (rnm (gensym))))
     390        (let (
     391          (?mtx (cadr frm))
     392          (?var (caddr frm))
     393          (?body (cdddr frm)))
    405394          (call-with-values
    406395            (lambda ()
    407396              (if (not (pair? ?mtx))
    408397                (values ?mtx '() '())
    409                 (let ((mtx (car ?mtx))
    410                       (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    411                       (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     398                (let (
     399                  (mtx (car ?mtx))
     400                  (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     401                  (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    412402                  (values mtx lock-args unlock-args) ) ) )
    413403            (lambda (?mtx ?lock-args ?unlock-args)
     
    481471  (er-macro-transformer
    482472    (lambda (frm rnm cmp)
    483       ;
    484473      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
    485       ;
    486474      (let (
    487475        (_%synch-with (rnm '%synch-with) )
     
    491479        (_begin (rnm 'begin) )
    492480        (mtxvar (rnm (gensym)) ) )
    493         ;
    494481        (let (
    495482          (?mtx (cadr frm) )
    496483          (?var (caddr frm) )
    497484          (?body (cdddr frm) ) )
    498           ;
    499485          `(,_let ((,mtxvar ,?mtx))
    500486             (,_%synch-with ,mtxvar ,?var
     
    545531  (er-macro-transformer
    546532    (lambda (frm rnm cmp)
    547       ;
    548533      (##sys#check-syntax '%object-synch-cut-with frm '(_ _ . _))
    549       ;
    550534      (let (
    551535        (_%synch-with (rnm '%synch-with))
     
    553537        (var (rnm (gensym)))
    554538        (mtx (cadr frm)) )
    555         ;
    556539        (let body-loop ((unparsed (cddr frm)) (parsed '()))
    557540          (if (null? unparsed)
    558             ;
     541            ;code walked
    559542            `(,_%synch-with ,mtx ,var ,@(reverse parsed))
    560             ;
     543            ;walk code
    561544            (let (
    562545              (expr (car unparsed))
    563546              (next (cdr unparsed)) )
    564               ;
    565547              (let expr-loop ((rest expr) (parsed-expr '()))
    566548                (cond
    567                   ;
    568549                  ((null? rest)
    569550                    (body-loop next (cons (reverse parsed-expr) parsed)))
    570                   ;
    571551                  ((pair? rest)
    572                     (let ((arg (car rest))
    573                           (next (cdr rest)))
     552                    (let (
     553                      (arg (car rest))
     554                      (next (cdr rest)))
    574555                      (if (cmp _>< arg)
    575                           (expr-loop next (cons var parsed-expr))
    576                           (expr-loop next (cons arg parsed-expr)) ) ))
    577                   ;
     556                        (expr-loop next (cons var parsed-expr))
     557                        (expr-loop next (cons arg parsed-expr)) ) ))
    578558                  ((cmp _>< rest)
    579559                    (body-loop next (cons var parsed)))
    580                   ;
    581560                  (else
    582561                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )
     
    635614;;
    636615
     616(define (datum-unbound-value? datum)
     617        (or (eq? (void) datum) (not datum)) )
     618
    637619(define (mutex-with-object? obj)
    638620        (and
    639621          (mutex? obj)
    640     (not (eq? (void) (mutex-specific obj))) ) )
    641 
    642 ;;
    643 
    644 (define (make-synch-with-object obj #!optional (name '(object-synch-)))
     622    (not (datum-unbound-value? (mutex-specific obj))) ) )
     623
     624;;
     625
     626(define (make-synch-with-object obj #!optional (name '(synchobj)))
    645627  (let* (
    646628    (name (if (pair? name) (gensym (car name)) name) )
    647629    (mutex (make-mutex name) ) )
    648     ;
    649630    (mutex-specific-set! mutex obj)
    650631    mutex ) )
     
    662643
    663644(define (synchronized-procedure proc)
    664   (let ((mtx (make-synch-with-object proc 'synchronized-procedure)))
     645  (let ((mtx (make-synch-with-object proc '(synchproc))))
    665646    (lambda args
    666647      (synch-with mtx proc
     
    671652;FIXME this API sucks
    672653
    673 (define-for-syntax (synch-wrapper-name sym)
    674         (string->symbol (string-append (symbol->string sym) "-" "synch")) )
     654(define-for-syntax (synch-wrapper-name sym) (suffix-symbol sym "synch"))
    675655
    676656(define-syntax define-constructor-synch
    677657  (er-macro-transformer
    678658    (lambda (frm rnm cmp)
    679       ;
    680659      (##sys#check-syntax 'define-constructor-synch frm '(_ symbol . _))
    681       ;
    682660      (let (
    683661        (_define (rnm 'define) )
     
    685663        (_args (rnm (gensym 'args)) )
    686664        (_make-synch-with-object (rnm 'make-synch-with-object) ) )
    687         ;
    688665        (let* (
    689666          (prcnam (cadr frm) )
    690667          (id (if (not (null? (cddr frm))) `('(,(caddr frm))) `('(,prcnam))) )
    691668          (newnam (synch-wrapper-name prcnam) ) )
    692           ;
    693669          `(,_define (,newnam . ,_args)
    694670            (,_make-synch-with-object (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
     
    697673  (er-macro-transformer
    698674    (lambda (frm rnm cmp)
    699       ;
    700675      (##sys#check-syntax 'define-predicate-synch frm '(_ symbol))
    701       ;
    702676      (let (
    703677        (_define (rnm 'define))
    704678        (_obj (rnm (gensym 'obj)))
    705679        (_synch-with-object? (rnm 'synch-with-object?)) )
    706         ;
    707680        (let* (
    708681          (prcnam (cadr frm))
    709682          (newnam (synch-wrapper-name prcnam)) )
    710           ;
    711683          `(,_define (,newnam ,_obj)
    712684            (,_synch-with-object? ,_obj ,prcnam)) ) ) ) ) )
     
    716688  (er-macro-transformer
    717689    (lambda (frm rnm cmp)
    718       ;
    719690      (##sys#check-syntax 'define-operation-synch frm '(_ symbol))
    720       ;
    721       (let ((_define (rnm 'define))
    722             (_apply (rnm 'apply))
    723             (_let (rnm 'let))
    724             (_car (rnm 'car))
    725             (_cdr (rnm 'cdr))
    726             (_if (rnm 'if))
    727             (_pair? (rnm 'pair?))
    728             (_synch-with (rnm 'synch-with))
    729             (_check-synch-with-object (rnm 'check-synch-with-object))
    730             (_mutex-specific (rnm 'mutex-specific))
    731             (_mtx+obj (rnm (gensym 'mtx+obj)))
    732             (_args (rnm (gensym 'args)))
    733             (_obj (rnm (gensym 'obj)))
    734             (_mtx (rnm (gensym 'mtx))) )
    735         (let* ((prcnam  (cadr frm))
    736                (newnam (synch-wrapper-name prcnam)) )
     691      (let (
     692        (_define (rnm 'define))
     693        (_apply (rnm 'apply))
     694        (_let (rnm 'let))
     695        (_car (rnm 'car))
     696        (_cdr (rnm 'cdr))
     697        (_if (rnm 'if))
     698        (_pair? (rnm 'pair?))
     699        (_synch-with (rnm 'synch-with))
     700        (_check-synch-with-object (rnm 'check-synch-with-object))
     701        (_mutex-specific (rnm 'mutex-specific))
     702        (_mtx+obj (rnm (gensym 'mtx+obj)))
     703        (_args (rnm (gensym 'args)))
     704        (_obj (rnm (gensym 'obj)))
     705        (_mtx (rnm (gensym 'mtx))) )
     706        (let* (
     707          (prcnam  (cadr frm))
     708           (newnam (synch-wrapper-name prcnam)) )
    737709          `(,_define (,newnam ,_mtx+obj . ,_args)
    738710             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     
    740712               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
    741713
     714(define-for-syntax (%synch-wrapper-name sym) (suffix-symbol sym "%synch"))
     715
    742716;operand must be the 1st argument
    743717(define-syntax define-operation-%synch
    744718  (er-macro-transformer
    745719    (lambda (frm rnm cmp)
    746       ;
    747       (define (%synch-wrapper-name sym)
    748         (string->symbol (string-append (symbol->string sym) "-" "%synch")) )
    749       ;
    750720      (##sys#check-syntax 'define-operation-%synch frm '(_ symbol))
    751       (let ((_define (rnm 'define))
    752             (_apply (rnm 'apply))
    753             (_let (rnm 'let))
    754             (_car (rnm 'car))
    755             (_cdr (rnm 'cdr))
    756             (_if (rnm 'if))
    757             (_pair? (rnm 'pair?))
    758             (_%synch-with (rnm '%synch-with))
    759             (_check-synch-with-object (rnm 'check-synch-with-object))
    760             (_mtx+obj (rnm (gensym 'mtx+obj)))
    761             (_args (rnm (gensym 'args)))
    762             (_obj (rnm (gensym 'obj)))
    763             (_mtx (rnm (gensym 'mtx))) )
     721      (let (
     722        (_define (rnm 'define))
     723        (_apply (rnm 'apply))
     724        (_let (rnm 'let))
     725        (_car (rnm 'car))
     726        (_cdr (rnm 'cdr))
     727        (_if (rnm 'if))
     728        (_pair? (rnm 'pair?))
     729        (_%synch-with (rnm '%synch-with))
     730        (_check-synch-with-object (rnm 'check-synch-with-object))
     731        (_mtx+obj (rnm (gensym 'mtx+obj)))
     732        (_args (rnm (gensym 'args)))
     733        (_obj (rnm (gensym 'obj)))
     734        (_mtx (rnm (gensym 'mtx))) )
    764735        (let* (
    765736          (prcnam (cadr frm))
    766737          (newnam (%synch-wrapper-name prcnam)) )
    767           ;
    768738          `(,_define (,newnam ,_mtx+obj . ,_args)
    769739             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
Note: See TracChangeset for help on using the changeset viewer.