Changeset 34225 in project


Ignore:
Timestamp:
07/04/17 02:19:28 (5 months ago)
Author:
kon
Message:

re-flow

Location:
release/4/synch
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/synch/tags/2.1.4/synch.scm

    r26458 r34225  
    11;;;; synch.scm
     2;;;; Kon Lovett, May '17
    23;;;; Kon Lovett, Mar '06
    34
     
    89(module synch
    910
    10   (;export
    11     ;;
    12     synch
    13     synch-with
    14     call/synch
    15     call-with/synch
    16     apply/synch
    17     apply-with/synch
    18     let/synch
    19     set!/synch
    20     synch/lock
    21     synch/unlock
    22     object/synch
    23     record/synch
    24     record-synch/lock
    25     record-synch/unlock
    26     ;;
    27     %synch
    28     %synch-with
    29     %call/synch
    30     %call-with/synch
    31     %apply/synch
    32     %apply-with/synch
    33     %let/synch
    34     %set!/synch
    35     %synch/lock
    36     %synch/unlock
    37     %object/synch
    38     %record/synch
    39     %record-synch/lock
    40     %record-synch/unlock
    41     ;;
    42     make-object/synch
    43     object?/synch
    44     ;;
    45     define-constructor/synch
    46     define-predicate/synch
    47     (define-operation/synch check-mutex+object)
    48     define-operation/%synch)
    49 
    50   (import
    51     scheme
    52     (only chicken
    53       define-for-syntax optional
    54       void unless warning gensym dynamic-wind)
    55     (only data-structures any?)
    56     (only srfi-18
    57       thread?
    58       make-mutex mutex?
    59       mutex-specific mutex-specific-set!
    60       mutex-lock! mutex-unlock!
    61       mutex-state)
    62     (only type-checks define-check+error-type) )
    63 
    64   (import-for-syntax (only data-structures conc))
    65 
    66   (require-library data-structures srfi-18 type-checks)
     11(;export
     12  ;;
     13  synch
     14  synch-with
     15  call/synch
     16  call-with/synch
     17  apply/synch
     18  apply-with/synch
     19  let/synch
     20  set!/synch
     21  synch/lock
     22  synch/unlock
     23  object/synch
     24  record/synch
     25  record-synch/lock
     26  record-synch/unlock
     27  ;;
     28  %synch
     29  %synch-with
     30  %call/synch
     31  %call-with/synch
     32  %apply/synch
     33  %apply-with/synch
     34  %let/synch
     35  %set!/synch
     36  %synch/lock
     37  %synch/unlock
     38  %object/synch
     39  %record/synch
     40  %record-synch/lock
     41  %record-synch/unlock
     42  ;;
     43  make-object/synch
     44  object?/synch
     45  ;;
     46  define-constructor/synch
     47  define-predicate/synch
     48  (define-operation/synch check-mutex+object)
     49  define-operation/%synch)
     50
     51(import scheme)
     52
     53(import
     54  (only chicken
     55    declare
     56    define-for-syntax optional
     57    void unless warning gensym dynamic-wind)
     58  (only data-structures any?)
     59  (only srfi-18
     60    thread?
     61    make-mutex mutex?
     62    mutex-specific mutex-specific-set!
     63    mutex-lock! mutex-unlock!
     64    mutex-state) )
     65
     66(import-for-syntax (only data-structures conc))
     67
     68(import (only type-checks define-check+error-type) )
     69(require-library type-checks)
    6770
    6871;;;
    6972
    70 (define-for-syntax (recmuxnam nam) (string->symbol (conc nam #\- 'mutex)))
     73(define-for-syntax (record-mutex-name nam)
     74  (string->symbol (conc nam #\- 'mutex)) )
    7175
    7276;;; Protected
    7377
     78;;
     79
    7480(define-syntax synch
    7581        (syntax-rules ()
     82    ;
    7683                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
    7784        (let ((mtx ?mtx))
     
    8087          (lambda () ?body ...)
    8188          (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     89    ;
    8290                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    8391        (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
     92    ;
    8493                ((_ ?mtx ?body ...)
    8594        (synch (?mtx () ()) ?body ...) ) ) )
     95
     96;;
    8697
    8798(define-syntax synch-with
     
    99110          (call-with-values
    100111            (lambda ()
    101               (if (not (pair? ?mtx)) (values ?mtx '() '())
    102                   (let ((mtx (car ?mtx))
    103                         (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    104                         (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    105                     (values mtx lock-args unlock-args) ) ) )
     112              (if (not (pair? ?mtx))
     113                (values ?mtx '() '())
     114                (let ((mtx (car ?mtx))
     115                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     116                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     117                  (values mtx lock-args unlock-args) ) ) )
    106118            (lambda (?mtx ?lock-args ?unlock-args)
    107119              `(,_let ((,mtxvar ,?mtx))
     
    114126(define-syntax call/synch
    115127        (syntax-rules ()
     128    ;
    116129                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    117130                  (let ((mtx ?mtx))
     
    120133                                  (lambda () (?proc ?arg0 ...))
    121134                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     135    ;
    122136                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    123137                  (call/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     138    ;
    124139                ((_ ?mtx ?proc ?arg0 ...)
    125140                  (call/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     
    127142(define-syntax call-with/synch
    128143        (syntax-rules ()
     144    ;
    129145                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    130146                  (let ((mtx ?mtx))
     
    133149                                  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
    134150                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     151    ;
    135152                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    136153                  (call-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     154    ;
    137155                ((_ ?mtx ?proc ?arg0 ...)
    138156                  (call-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     
    148166          ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    149167                  (apply/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     168    ;
    150169                ((_ ?mtx ?proc ?arg0 ...)
    151170                  (apply/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     
    153172(define-syntax apply-with/synch
    154173        (syntax-rules ()
     174    ;
    155175                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    156176                  (let ((mtx ?mtx))
     
    159179                                  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
    160180                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     181    ;
    161182                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    162183                  (apply-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     184    ;
    163185                ((_ ?mtx ?proc ?arg0 ...)
    164186                  (apply-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     
    172194               (res
    173195                (let loop ((bnds (cadr frm)))
    174                   (if (null? bnds) ?body
    175                       (let ((?bnd (car bnds)))
    176                         (##sys#check-syntax 'let/synch ?bnd '(variable . _))
    177                         `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
     196                  (if (null? bnds)
     197                    ?body
     198                    (let ((?bnd (car bnds)))
     199                      (##sys#check-syntax 'let/synch ?bnd '(variable . _))
     200                      `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
    178201          (car res) ) ) ) ) )
    179202
     
    194217               (,_mutex-specific ,?mtx) ) ) ) ) ) ) )
    195218
     219;;
     220
    196221(define-syntax synch/lock
    197222        (syntax-rules ()
     223    ;
    198224                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    199225                  (let ((mtx ?mtx) (ok? #f))
     
    203229                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
    204230                                        (lambda () (unless ok? (mutex-unlock! mtx)))) ) )
     231    ;
    205232                ((_ ?mtx ?body ...)
    206233                  (synch/lock (?mtx ()) ?body ...) ) ) )
     
    208235(define-syntax synch/unlock
    209236        (syntax-rules ()
     237    ;
    210238                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
    211239                  (let ((mtx ?mtx))
     
    217245                                  (lambda () ?body ...)
    218246                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     247    ;
    219248                ((_ ?mtx ?body ...)
    220249                  (synch/unlock (?mtx ()) ?body ...) ) ) )
     250
     251;;
    221252
    222253(define-syntax object/synch
     
    230261        (let body-loop ((unparsed (cddr frm)) (parsed '()))
    231262          (if (not (null? unparsed))
    232               (let ((expr (car unparsed))
    233                     (next (cdr unparsed)))
    234                 (let expr-loop ((rest expr) (parsedexpr '()))
    235                   (cond ((null? rest)
    236                           (body-loop next (cons (reverse parsedexpr) parsed)))
    237                         ((pair? rest)
    238                           (let ((arg (car rest))
    239                                 (next (cdr rest)))
    240                             (if (cmp _>< arg)
    241                                 (expr-loop next (cons var parsedexpr))
    242                                 (expr-loop next (cons arg parsedexpr)) ) ))
    243                         ((cmp _>< rest)
    244                           (body-loop next (cons var parsed)))
    245                         (else
    246                           (body-loop next (cons rest parsed))) ) ) )
    247               `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
     263            (let ((expr (car unparsed))
     264                  (next (cdr unparsed)))
     265              (let expr-loop ((rest expr) (parsedexpr '()))
     266                (cond
     267                  ((null? rest)
     268                    (body-loop next (cons (reverse parsedexpr) parsed)))
     269                  ((pair? rest)
     270                    (let ((arg (car rest))
     271                          (next (cdr rest)))
     272                      (if (cmp _>< arg)
     273                        (expr-loop next (cons var parsedexpr))
     274                        (expr-loop next (cons arg parsedexpr)) ) ))
     275                  ((cmp _>< rest)
     276                    (body-loop next (cons var parsed)))
     277                  (else
     278                    (body-loop next (cons rest parsed))) ) ) )
     279            `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
     280
     281;;
    248282
    249283(define-syntax record/synch
     
    255289              (?rec (caddr frm))
    256290              (?body (cdddr frm)))
    257           `(,_synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     291          `(,_synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    258292
    259293(define-syntax record-synch/lock
     
    265299              (?rec (caddr frm))
    266300              (?body (cdddr frm)))
    267           `(,_synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     301          `(,_synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    268302
    269303(define-syntax record-synch/unlock
     
    275309              (?rec (caddr frm))
    276310              (?body (cdddr frm)))
    277           `(,_synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     311          `(,_synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    278312
    279313
     
    282316(define-syntax %*synch
    283317        (syntax-rules ()
     318    ;
    284319                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
    285320                  (let ((mtx ?mtx))
     
    290325                                                (mutex-unlock! mtx ?unlock-arg0 ...)
    291326                                                (apply values ret))) ) )
     327    ;
    292328                ((_ ?mtx ?body ...)
    293329                  (%*synch (?mtx () ()) ?body ...) ) ) )
     330
     331;;
    294332
    295333(define-syntax %*synch-with
     
    312350          (call-with-values
    313351            (lambda ()
    314               (if (not (pair? ?mtx)) (values ?mtx '() '())
     352              (if (not (pair? ?mtx))
     353                (values ?mtx '() '())
    315354                (let ((mtx (car ?mtx))
    316355                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     
    327366                       (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) ) )
    328367
     368;;
     369
    329370(define-syntax %synch
    330371        (syntax-rules ()
    331372                ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
    332373
     374;;
     375
    333376(define-syntax %synch-with
    334377        (syntax-rules ()
    335                 ((_ ?mtx ?var ?body ...) (%*synch-with ?mtx ?var ?body ...) ) ) )
     378                ((_ ?mtx ?var ?body ...)
     379                  (%*synch-with ?mtx ?var ?body ...) ) ) )
    336380
    337381(define-syntax %call/synch
    338382        (syntax-rules ()
    339                 ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
     383                ((_ ?mtx ?proc ?arg0 ...)
     384                  (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
    340385
    341386(define-syntax %call-with/synch
    342387        (syntax-rules ()
    343                 ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
     388                ((_ ?mtx ?proc ?arg0 ...)
     389                  (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
    344390
    345391(define-syntax %apply/synch
    346392        (syntax-rules ()
    347                 ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
     393                ((_ ?mtx ?proc ?arg0 ...)
     394                  (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
    348395
    349396(define-syntax %apply-with/synch
    350397        (syntax-rules ()
    351                 ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
     398                ((_ ?mtx ?proc ?arg0 ...)
     399                  (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
    352400
    353401(define-syntax %let/synch
     
    359407          (car
    360408            (let loop ((?bnds (cadr frm)))
    361               (if (null? ?bnds) ?body
     409              (if (null? ?bnds)
     410                ?body
    362411                (let ((bnd (car ?bnds)))
    363412                  (##sys#check-syntax '%let/synch bnd '(variable _))
     
    383432                 (,_mutex-specific ,mtxvar) ) ) ) ) ) ) ) )
    384433
     434;;
     435
    385436(define-syntax %synch/lock
    386437        (syntax-rules ()
     438    ;
    387439                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    388440                  (let ((mtx ?mtx) (ok? #f))
     
    393445                                                (unless ok? (mutex-unlock! mtx))
    394446                                                (apply values ret))) ) )
     447    ;
    395448                ((_ ?mtx ?body ...)
    396449                  (%synch/lock (?mtx ()) ?body ...) ) ) )
     
    398451(define-syntax %synch/unlock
    399452        (syntax-rules ()
     453    ;
    400454                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
    401455      (let ((mtx ?mtx))
     
    408462            (mutex-unlock! mtx ?unlock-arg0 ...)
    409463            (apply values ret)) ) ) )
     464    ;
    410465                ((_ ?mtx ?body ...)
    411466      (%synch/unlock (?mtx ()) ?body ...) ) ) )
     467
     468;;
    412469
    413470(define-syntax %object/synch
     
    421478        (let body-loop ((unparsed (cddr frm)) (parsed '()))
    422479          (if (not (null? unparsed))
    423               (let ((expr (car unparsed))
    424                     (next (cdr unparsed)))
    425                 (let expr-loop ((rest expr) (parsedexpr '()))
    426                   (cond ((null? rest)
    427                           (body-loop next (cons (reverse parsedexpr) parsed)))
    428                         ((pair? rest)
    429                           (let ((arg (car rest))
    430                                 (next (cdr rest)))
    431                             (if (cmp _>< arg)
    432                                 (expr-loop next (cons var parsedexpr))
    433                                 (expr-loop next (cons arg parsedexpr)) ) ))
    434                         ((cmp _>< rest)
    435                           (body-loop next (cons var parsed)))
    436                         (else
    437                           (body-loop next (cons rest parsed))) ) ) )
    438               `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
     480            (let ((expr (car unparsed))
     481                  (next (cdr unparsed)))
     482              (let expr-loop ((rest expr) (parsedexpr '()))
     483                (cond
     484                  ((null? rest)
     485                    (body-loop next (cons (reverse parsedexpr) parsed)))
     486                  ((pair? rest)
     487                    (let ((arg (car rest))
     488                          (next (cdr rest)))
     489                      (if (cmp _>< arg)
     490                          (expr-loop next (cons var parsedexpr))
     491                          (expr-loop next (cons arg parsedexpr)) ) ))
     492                  ((cmp _>< rest)
     493                    (body-loop next (cons var parsed)))
     494                  (else
     495                    (body-loop next (cons rest parsed))) ) ) )
     496            `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
     497
     498;;
    439499
    440500(define-syntax %record/synch
     
    446506              (?rec (caddr frm))
    447507              (?body (cdddr frm)))
    448           `(,_%synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     508          `(,_%synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    449509
    450510(define-syntax %record-synch/lock
     
    456516            (?rec (caddr frm))
    457517            (?body (cdddr frm)))
    458         `(,_%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     518        `(,_%synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    459519
    460520(define-syntax %record-synch/unlock
     
    466526              (?rec (caddr frm))
    467527              (?body (cdddr frm)))
    468           `(,_%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     528          `(,_%synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    469529
    470530
     
    472532
    473533(define (mutex+object? obj)
    474         (and (mutex? obj)
    475                    (not (eq? (void) (mutex-specific obj)))) )
     534        (and
     535          (mutex? obj)
     536    (not (eq? (void) (mutex-specific obj))) ) )
    476537
    477538(define-check+error-type mutex+object)
     
    482543  (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
    483544    (mutex-specific-set! mutex obj)
    484     mutex) )
     545    mutex ) )
    485546
    486547(define (object?/synch obj #!optional (pred any?))
    487   (and (mutex+object? obj)
    488        (pred (mutex-specific obj))) )
    489 
    490 ;;
    491 
    492 (define-for-syntax (synchsym sym)
     548  (and
     549    (mutex+object? obj)
     550     (pred (mutex-specific obj))) )
     551
     552;;
     553
     554(define-for-syntax (synch-wrapper-name sym)
    493555        (string->symbol (string-append (symbol->string sym) "/synch")) )
    494 
    495 ;;
    496556
    497557(define-syntax define-constructor/synch
     
    505565        (let* ((prcnam (cadr frm))
    506566               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
    507                (newnam (synchsym prcnam)) )
     567               (newnam (synch-wrapper-name prcnam)) )
    508568          `(,_define (,newnam . ,_args)
    509569             (,_make-object/synch (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
    510 
    511 ;;
    512570
    513571(define-syntax define-predicate/synch
     
    519577            (_object?/synch (rnm 'object?/synch)) )
    520578        (let* ((prcnam (cadr frm))
    521                (newnam (synchsym prcnam)) )
     579               (newnam (synch-wrapper-name prcnam)) )
    522580          `(,_define (,newnam ,_obj) (,_object?/synch ,_obj ,prcnam)) ) ) ) ) )
    523581
    524 ;;
    525 
    526582;operand must be the 1st argument
    527 
    528583(define-syntax define-operation/synch
    529584  (er-macro-transformer
     
    545600            (_mtx (rnm (gensym 'mtx))) )
    546601        (let* ((prcnam  (cadr frm))
    547                (newnam (synchsym prcnam)) )
     602               (newnam (synch-wrapper-name prcnam)) )
    548603          `(,_define (,newnam ,_mtx+obj . ,_args)
    549604             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     
    554609
    555610;operand must be the 1st argument
    556 
    557611(define-syntax define-operation/%synch
    558612  (er-macro-transformer
    559613    (lambda (frm rnm cmp)
    560       (define (%synchsym sym) (string->symbol (string-append (symbol->string sym) "/%synch")))
     614      ;
     615      (define (%synch-wrapper-name sym)
     616        (string->symbol (string-append (symbol->string sym) "/%synch")) )
     617      ;
    561618      (##sys#check-syntax 'define-operation/%synch frm '(_ symbol))
    562619      (let ((_define (rnm 'define))
     
    574631            (_mtx (rnm (gensym 'mtx))) )
    575632        (let* ((prcnam (cadr frm))
    576                (newnam (%synchsym prcnam)) )
     633               (newnam (%synch-wrapper-name prcnam)) )
    577634          `(,_define (,newnam ,_mtx+obj . ,_args)
    578635             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
  • release/4/synch/tags/2.1.4/synch.setup

    r33416 r34225  
    55(verify-extension-name 'synch)
    66
    7 (setup-shared-extension-module 'synch (extension-version "2.1.3")
     7(setup-shared-extension-module 'synch (extension-version "2.1.4")
     8  #:inline? #t
     9  #:types? #t
    810  #:compile-options '(
    9     -disable-interrupts
    10     -fixnum-arithmetic
    11     -optimize-level 3 -debug-level 1))
     11    -optimize-level 3 -debug-level 2))
  • release/4/synch/tags/2.1.4/tests/run.scm

    r16026 r34225  
     1;;;; synch test
     2
    13(use srfi-18 srfi-69 synch miscmacros)
    24
    3 (define-record-type foo
    4   (make-foo x y mtx)
    5   foo?
    6   (x foo-x)
    7   (y foo-y)
    8   (mtx foo-mutex))
    9  
    10 (define tfoo (make-foo 1 2 (make-mutex)))
     5;;
     6
     7(define-syntax define-thread
     8        (syntax-rules ()
     9          ((_ ?ident ?body ...)
     10            (define ?ident
     11        (make-thread
     12          (lambda () ?body ...)
     13          '?ident) ) ) ) )
     14
     15;;;
     16
     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)))
    1125(print "*** prints 1 2 ***")
    12 (record/synch foo tfoo (print (foo-x tfoo) " " (foo-y tfoo)))
     26(record/synch <foo> tfoo (print (<foo>-x tfoo) " " (<foo>-y tfoo)))
    1327(newline)
     28
     29;;; Synchronize thread access to an object
    1430
    1531;;
     
    1935  (hash-table-fold ht (lambda (k v a) (fx+ a 1)) 0) )
    2036
    21 ;;;
     37;;
    2238
    2339(define-constructor/synch make-hash-table hash-table/synch:)
     
    3046(define +tht+ (make-hash-table/synch = number-hash))
    3147
    32 ;; Greedy reader
     48(define-constant READER-THREAD-LIMIT 20)
    3349
    34 (define (reader)
     50(define-constant THREAD-SLEEP-MS 0 #;2000)
     51
     52;; Greedy Reader
     53
     54(define-thread reader-thread
    3555  (do ((n (hash-table-count/synch +tht+) (hash-table-count/synch +tht+)))
    36       ((fx= 20 n) (print "test hash-table count = " n " so quit"))
    37     (print "test hash-table count = " n) ) )
    38 (define reader-thread (make-thread reader 'reader))
    39 (thread-start! reader-thread)
     56      ((fx= READER-THREAD-LIMIT n)
     57        (print "test hash-table count = " n " so quit"))
     58    (print "test hash-table count = " n)
     59    (thread-sleep! THREAD-SLEEP-MS) ) )
    4060
    41 ;; Cooperative writer
     61;; Cooperative Writer
    4262
    43 (define (writer)
     63(define-thread writer-thread
    4464  (repeat* 10
    4565    (hash-table-set!/synch +tht+ it (number->string it))
    4666    (hash-table-set!/synch +tht+ (* it 11) (number->string it))
     67    (thread-sleep! THREAD-SLEEP-MS)
    4768    (thread-yield!) ) )
    48 (define writer-thread (make-thread writer 'writer))
    49 (thread-start! writer-thread)
    5069
    5170;;
    5271
     72(thread-start! writer-thread)
     73(thread-start! reader-thread)
     74
    5375(thread-join! writer-thread)
    5476(thread-join! reader-thread)
  • release/4/synch/trunk/synch.scm

    r26458 r34225  
    11;;;; synch.scm
     2;;;; Kon Lovett, May '17
    23;;;; Kon Lovett, Mar '06
    34
     
    89(module synch
    910
    10   (;export
    11     ;;
    12     synch
    13     synch-with
    14     call/synch
    15     call-with/synch
    16     apply/synch
    17     apply-with/synch
    18     let/synch
    19     set!/synch
    20     synch/lock
    21     synch/unlock
    22     object/synch
    23     record/synch
    24     record-synch/lock
    25     record-synch/unlock
    26     ;;
    27     %synch
    28     %synch-with
    29     %call/synch
    30     %call-with/synch
    31     %apply/synch
    32     %apply-with/synch
    33     %let/synch
    34     %set!/synch
    35     %synch/lock
    36     %synch/unlock
    37     %object/synch
    38     %record/synch
    39     %record-synch/lock
    40     %record-synch/unlock
    41     ;;
    42     make-object/synch
    43     object?/synch
    44     ;;
    45     define-constructor/synch
    46     define-predicate/synch
    47     (define-operation/synch check-mutex+object)
    48     define-operation/%synch)
    49 
    50   (import
    51     scheme
    52     (only chicken
    53       define-for-syntax optional
    54       void unless warning gensym dynamic-wind)
    55     (only data-structures any?)
    56     (only srfi-18
    57       thread?
    58       make-mutex mutex?
    59       mutex-specific mutex-specific-set!
    60       mutex-lock! mutex-unlock!
    61       mutex-state)
    62     (only type-checks define-check+error-type) )
    63 
    64   (import-for-syntax (only data-structures conc))
    65 
    66   (require-library data-structures srfi-18 type-checks)
     11(;export
     12  ;;
     13  synch
     14  synch-with
     15  call/synch
     16  call-with/synch
     17  apply/synch
     18  apply-with/synch
     19  let/synch
     20  set!/synch
     21  synch/lock
     22  synch/unlock
     23  object/synch
     24  record/synch
     25  record-synch/lock
     26  record-synch/unlock
     27  ;;
     28  %synch
     29  %synch-with
     30  %call/synch
     31  %call-with/synch
     32  %apply/synch
     33  %apply-with/synch
     34  %let/synch
     35  %set!/synch
     36  %synch/lock
     37  %synch/unlock
     38  %object/synch
     39  %record/synch
     40  %record-synch/lock
     41  %record-synch/unlock
     42  ;;
     43  make-object/synch
     44  object?/synch
     45  ;;
     46  define-constructor/synch
     47  define-predicate/synch
     48  (define-operation/synch check-mutex+object)
     49  define-operation/%synch)
     50
     51(import scheme)
     52
     53(import
     54  (only chicken
     55    declare
     56    define-for-syntax optional
     57    void unless warning gensym dynamic-wind)
     58  (only data-structures any?)
     59  (only srfi-18
     60    thread?
     61    make-mutex mutex?
     62    mutex-specific mutex-specific-set!
     63    mutex-lock! mutex-unlock!
     64    mutex-state) )
     65
     66(import-for-syntax (only data-structures conc))
     67
     68(import (only type-checks define-check+error-type) )
     69(require-library type-checks)
    6770
    6871;;;
    6972
    70 (define-for-syntax (recmuxnam nam) (string->symbol (conc nam #\- 'mutex)))
     73(define-for-syntax (record-mutex-name nam)
     74  (string->symbol (conc nam #\- 'mutex)) )
    7175
    7276;;; Protected
    7377
     78;;
     79
    7480(define-syntax synch
    7581        (syntax-rules ()
     82    ;
    7683                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
    7784        (let ((mtx ?mtx))
     
    8087          (lambda () ?body ...)
    8188          (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     89    ;
    8290                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    8391        (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
     92    ;
    8493                ((_ ?mtx ?body ...)
    8594        (synch (?mtx () ()) ?body ...) ) ) )
     95
     96;;
    8697
    8798(define-syntax synch-with
     
    99110          (call-with-values
    100111            (lambda ()
    101               (if (not (pair? ?mtx)) (values ?mtx '() '())
    102                   (let ((mtx (car ?mtx))
    103                         (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    104                         (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    105                     (values mtx lock-args unlock-args) ) ) )
     112              (if (not (pair? ?mtx))
     113                (values ?mtx '() '())
     114                (let ((mtx (car ?mtx))
     115                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     116                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     117                  (values mtx lock-args unlock-args) ) ) )
    106118            (lambda (?mtx ?lock-args ?unlock-args)
    107119              `(,_let ((,mtxvar ,?mtx))
     
    114126(define-syntax call/synch
    115127        (syntax-rules ()
     128    ;
    116129                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    117130                  (let ((mtx ?mtx))
     
    120133                                  (lambda () (?proc ?arg0 ...))
    121134                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     135    ;
    122136                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    123137                  (call/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     138    ;
    124139                ((_ ?mtx ?proc ?arg0 ...)
    125140                  (call/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     
    127142(define-syntax call-with/synch
    128143        (syntax-rules ()
     144    ;
    129145                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    130146                  (let ((mtx ?mtx))
     
    133149                                  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
    134150                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     151    ;
    135152                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    136153                  (call-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     154    ;
    137155                ((_ ?mtx ?proc ?arg0 ...)
    138156                  (call-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     
    148166          ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    149167                  (apply/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     168    ;
    150169                ((_ ?mtx ?proc ?arg0 ...)
    151170                  (apply/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     
    153172(define-syntax apply-with/synch
    154173        (syntax-rules ()
     174    ;
    155175                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
    156176                  (let ((mtx ?mtx))
     
    159179                                  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
    160180                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     181    ;
    161182                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    162183                  (apply-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     184    ;
    163185                ((_ ?mtx ?proc ?arg0 ...)
    164186                  (apply-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     
    172194               (res
    173195                (let loop ((bnds (cadr frm)))
    174                   (if (null? bnds) ?body
    175                       (let ((?bnd (car bnds)))
    176                         (##sys#check-syntax 'let/synch ?bnd '(variable . _))
    177                         `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
     196                  (if (null? bnds)
     197                    ?body
     198                    (let ((?bnd (car bnds)))
     199                      (##sys#check-syntax 'let/synch ?bnd '(variable . _))
     200                      `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
    178201          (car res) ) ) ) ) )
    179202
     
    194217               (,_mutex-specific ,?mtx) ) ) ) ) ) ) )
    195218
     219;;
     220
    196221(define-syntax synch/lock
    197222        (syntax-rules ()
     223    ;
    198224                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    199225                  (let ((mtx ?mtx) (ok? #f))
     
    203229                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
    204230                                        (lambda () (unless ok? (mutex-unlock! mtx)))) ) )
     231    ;
    205232                ((_ ?mtx ?body ...)
    206233                  (synch/lock (?mtx ()) ?body ...) ) ) )
     
    208235(define-syntax synch/unlock
    209236        (syntax-rules ()
     237    ;
    210238                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
    211239                  (let ((mtx ?mtx))
     
    217245                                  (lambda () ?body ...)
    218246                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
     247    ;
    219248                ((_ ?mtx ?body ...)
    220249                  (synch/unlock (?mtx ()) ?body ...) ) ) )
     250
     251;;
    221252
    222253(define-syntax object/synch
     
    230261        (let body-loop ((unparsed (cddr frm)) (parsed '()))
    231262          (if (not (null? unparsed))
    232               (let ((expr (car unparsed))
    233                     (next (cdr unparsed)))
    234                 (let expr-loop ((rest expr) (parsedexpr '()))
    235                   (cond ((null? rest)
    236                           (body-loop next (cons (reverse parsedexpr) parsed)))
    237                         ((pair? rest)
    238                           (let ((arg (car rest))
    239                                 (next (cdr rest)))
    240                             (if (cmp _>< arg)
    241                                 (expr-loop next (cons var parsedexpr))
    242                                 (expr-loop next (cons arg parsedexpr)) ) ))
    243                         ((cmp _>< rest)
    244                           (body-loop next (cons var parsed)))
    245                         (else
    246                           (body-loop next (cons rest parsed))) ) ) )
    247               `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
     263            (let ((expr (car unparsed))
     264                  (next (cdr unparsed)))
     265              (let expr-loop ((rest expr) (parsedexpr '()))
     266                (cond
     267                  ((null? rest)
     268                    (body-loop next (cons (reverse parsedexpr) parsed)))
     269                  ((pair? rest)
     270                    (let ((arg (car rest))
     271                          (next (cdr rest)))
     272                      (if (cmp _>< arg)
     273                        (expr-loop next (cons var parsedexpr))
     274                        (expr-loop next (cons arg parsedexpr)) ) ))
     275                  ((cmp _>< rest)
     276                    (body-loop next (cons var parsed)))
     277                  (else
     278                    (body-loop next (cons rest parsed))) ) ) )
     279            `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
     280
     281;;
    248282
    249283(define-syntax record/synch
     
    255289              (?rec (caddr frm))
    256290              (?body (cdddr frm)))
    257           `(,_synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     291          `(,_synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    258292
    259293(define-syntax record-synch/lock
     
    265299              (?rec (caddr frm))
    266300              (?body (cdddr frm)))
    267           `(,_synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     301          `(,_synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    268302
    269303(define-syntax record-synch/unlock
     
    275309              (?rec (caddr frm))
    276310              (?body (cdddr frm)))
    277           `(,_synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     311          `(,_synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    278312
    279313
     
    282316(define-syntax %*synch
    283317        (syntax-rules ()
     318    ;
    284319                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
    285320                  (let ((mtx ?mtx))
     
    290325                                                (mutex-unlock! mtx ?unlock-arg0 ...)
    291326                                                (apply values ret))) ) )
     327    ;
    292328                ((_ ?mtx ?body ...)
    293329                  (%*synch (?mtx () ()) ?body ...) ) ) )
     330
     331;;
    294332
    295333(define-syntax %*synch-with
     
    312350          (call-with-values
    313351            (lambda ()
    314               (if (not (pair? ?mtx)) (values ?mtx '() '())
     352              (if (not (pair? ?mtx))
     353                (values ?mtx '() '())
    315354                (let ((mtx (car ?mtx))
    316355                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     
    327366                       (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) ) )
    328367
     368;;
     369
    329370(define-syntax %synch
    330371        (syntax-rules ()
    331372                ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
    332373
     374;;
     375
    333376(define-syntax %synch-with
    334377        (syntax-rules ()
    335                 ((_ ?mtx ?var ?body ...) (%*synch-with ?mtx ?var ?body ...) ) ) )
     378                ((_ ?mtx ?var ?body ...)
     379                  (%*synch-with ?mtx ?var ?body ...) ) ) )
    336380
    337381(define-syntax %call/synch
    338382        (syntax-rules ()
    339                 ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
     383                ((_ ?mtx ?proc ?arg0 ...)
     384                  (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
    340385
    341386(define-syntax %call-with/synch
    342387        (syntax-rules ()
    343                 ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
     388                ((_ ?mtx ?proc ?arg0 ...)
     389                  (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
    344390
    345391(define-syntax %apply/synch
    346392        (syntax-rules ()
    347                 ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
     393                ((_ ?mtx ?proc ?arg0 ...)
     394                  (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
    348395
    349396(define-syntax %apply-with/synch
    350397        (syntax-rules ()
    351                 ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
     398                ((_ ?mtx ?proc ?arg0 ...)
     399                  (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
    352400
    353401(define-syntax %let/synch
     
    359407          (car
    360408            (let loop ((?bnds (cadr frm)))
    361               (if (null? ?bnds) ?body
     409              (if (null? ?bnds)
     410                ?body
    362411                (let ((bnd (car ?bnds)))
    363412                  (##sys#check-syntax '%let/synch bnd '(variable _))
     
    383432                 (,_mutex-specific ,mtxvar) ) ) ) ) ) ) ) )
    384433
     434;;
     435
    385436(define-syntax %synch/lock
    386437        (syntax-rules ()
     438    ;
    387439                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
    388440                  (let ((mtx ?mtx) (ok? #f))
     
    393445                                                (unless ok? (mutex-unlock! mtx))
    394446                                                (apply values ret))) ) )
     447    ;
    395448                ((_ ?mtx ?body ...)
    396449                  (%synch/lock (?mtx ()) ?body ...) ) ) )
     
    398451(define-syntax %synch/unlock
    399452        (syntax-rules ()
     453    ;
    400454                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
    401455      (let ((mtx ?mtx))
     
    408462            (mutex-unlock! mtx ?unlock-arg0 ...)
    409463            (apply values ret)) ) ) )
     464    ;
    410465                ((_ ?mtx ?body ...)
    411466      (%synch/unlock (?mtx ()) ?body ...) ) ) )
     467
     468;;
    412469
    413470(define-syntax %object/synch
     
    421478        (let body-loop ((unparsed (cddr frm)) (parsed '()))
    422479          (if (not (null? unparsed))
    423               (let ((expr (car unparsed))
    424                     (next (cdr unparsed)))
    425                 (let expr-loop ((rest expr) (parsedexpr '()))
    426                   (cond ((null? rest)
    427                           (body-loop next (cons (reverse parsedexpr) parsed)))
    428                         ((pair? rest)
    429                           (let ((arg (car rest))
    430                                 (next (cdr rest)))
    431                             (if (cmp _>< arg)
    432                                 (expr-loop next (cons var parsedexpr))
    433                                 (expr-loop next (cons arg parsedexpr)) ) ))
    434                         ((cmp _>< rest)
    435                           (body-loop next (cons var parsed)))
    436                         (else
    437                           (body-loop next (cons rest parsed))) ) ) )
    438               `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
     480            (let ((expr (car unparsed))
     481                  (next (cdr unparsed)))
     482              (let expr-loop ((rest expr) (parsedexpr '()))
     483                (cond
     484                  ((null? rest)
     485                    (body-loop next (cons (reverse parsedexpr) parsed)))
     486                  ((pair? rest)
     487                    (let ((arg (car rest))
     488                          (next (cdr rest)))
     489                      (if (cmp _>< arg)
     490                          (expr-loop next (cons var parsedexpr))
     491                          (expr-loop next (cons arg parsedexpr)) ) ))
     492                  ((cmp _>< rest)
     493                    (body-loop next (cons var parsed)))
     494                  (else
     495                    (body-loop next (cons rest parsed))) ) ) )
     496            `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
     497
     498;;
    439499
    440500(define-syntax %record/synch
     
    446506              (?rec (caddr frm))
    447507              (?body (cdddr frm)))
    448           `(,_%synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     508          `(,_%synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    449509
    450510(define-syntax %record-synch/lock
     
    456516            (?rec (caddr frm))
    457517            (?body (cdddr frm)))
    458         `(,_%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     518        `(,_%synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    459519
    460520(define-syntax %record-synch/unlock
     
    466526              (?rec (caddr frm))
    467527              (?body (cdddr frm)))
    468           `(,_%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
     528          `(,_%synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    469529
    470530
     
    472532
    473533(define (mutex+object? obj)
    474         (and (mutex? obj)
    475                    (not (eq? (void) (mutex-specific obj)))) )
     534        (and
     535          (mutex? obj)
     536    (not (eq? (void) (mutex-specific obj))) ) )
    476537
    477538(define-check+error-type mutex+object)
     
    482543  (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
    483544    (mutex-specific-set! mutex obj)
    484     mutex) )
     545    mutex ) )
    485546
    486547(define (object?/synch obj #!optional (pred any?))
    487   (and (mutex+object? obj)
    488        (pred (mutex-specific obj))) )
    489 
    490 ;;
    491 
    492 (define-for-syntax (synchsym sym)
     548  (and
     549    (mutex+object? obj)
     550     (pred (mutex-specific obj))) )
     551
     552;;
     553
     554(define-for-syntax (synch-wrapper-name sym)
    493555        (string->symbol (string-append (symbol->string sym) "/synch")) )
    494 
    495 ;;
    496556
    497557(define-syntax define-constructor/synch
     
    505565        (let* ((prcnam (cadr frm))
    506566               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
    507                (newnam (synchsym prcnam)) )
     567               (newnam (synch-wrapper-name prcnam)) )
    508568          `(,_define (,newnam . ,_args)
    509569             (,_make-object/synch (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
    510 
    511 ;;
    512570
    513571(define-syntax define-predicate/synch
     
    519577            (_object?/synch (rnm 'object?/synch)) )
    520578        (let* ((prcnam (cadr frm))
    521                (newnam (synchsym prcnam)) )
     579               (newnam (synch-wrapper-name prcnam)) )
    522580          `(,_define (,newnam ,_obj) (,_object?/synch ,_obj ,prcnam)) ) ) ) ) )
    523581
    524 ;;
    525 
    526582;operand must be the 1st argument
    527 
    528583(define-syntax define-operation/synch
    529584  (er-macro-transformer
     
    545600            (_mtx (rnm (gensym 'mtx))) )
    546601        (let* ((prcnam  (cadr frm))
    547                (newnam (synchsym prcnam)) )
     602               (newnam (synch-wrapper-name prcnam)) )
    548603          `(,_define (,newnam ,_mtx+obj . ,_args)
    549604             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     
    554609
    555610;operand must be the 1st argument
    556 
    557611(define-syntax define-operation/%synch
    558612  (er-macro-transformer
    559613    (lambda (frm rnm cmp)
    560       (define (%synchsym sym) (string->symbol (string-append (symbol->string sym) "/%synch")))
     614      ;
     615      (define (%synch-wrapper-name sym)
     616        (string->symbol (string-append (symbol->string sym) "/%synch")) )
     617      ;
    561618      (##sys#check-syntax 'define-operation/%synch frm '(_ symbol))
    562619      (let ((_define (rnm 'define))
     
    574631            (_mtx (rnm (gensym 'mtx))) )
    575632        (let* ((prcnam (cadr frm))
    576                (newnam (%synchsym prcnam)) )
     633               (newnam (%synch-wrapper-name prcnam)) )
    577634          `(,_define (,newnam ,_mtx+obj . ,_args)
    578635             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
  • release/4/synch/trunk/synch.setup

    r33416 r34225  
    55(verify-extension-name 'synch)
    66
    7 (setup-shared-extension-module 'synch (extension-version "2.1.3")
     7(setup-shared-extension-module 'synch (extension-version "2.1.4")
     8  #:inline? #t
     9  #:types? #t
    810  #:compile-options '(
    9     -disable-interrupts
    10     -fixnum-arithmetic
    11     -optimize-level 3 -debug-level 1))
     11    -optimize-level 3 -debug-level 2))
  • release/4/synch/trunk/tests/run.scm

    r16026 r34225  
     1;;;; synch test
     2
    13(use srfi-18 srfi-69 synch miscmacros)
    24
    3 (define-record-type foo
    4   (make-foo x y mtx)
    5   foo?
    6   (x foo-x)
    7   (y foo-y)
    8   (mtx foo-mutex))
    9  
    10 (define tfoo (make-foo 1 2 (make-mutex)))
     5;;
     6
     7(define-syntax define-thread
     8        (syntax-rules ()
     9          ((_ ?ident ?body ...)
     10            (define ?ident
     11        (make-thread
     12          (lambda () ?body ...)
     13          '?ident) ) ) ) )
     14
     15;;;
     16
     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)))
    1125(print "*** prints 1 2 ***")
    12 (record/synch foo tfoo (print (foo-x tfoo) " " (foo-y tfoo)))
     26(record/synch <foo> tfoo (print (<foo>-x tfoo) " " (<foo>-y tfoo)))
    1327(newline)
     28
     29;;; Synchronize thread access to an object
    1430
    1531;;
     
    1935  (hash-table-fold ht (lambda (k v a) (fx+ a 1)) 0) )
    2036
    21 ;;;
     37;;
    2238
    2339(define-constructor/synch make-hash-table hash-table/synch:)
     
    3046(define +tht+ (make-hash-table/synch = number-hash))
    3147
    32 ;; Greedy reader
     48(define-constant READER-THREAD-LIMIT 20)
    3349
    34 (define (reader)
     50(define-constant THREAD-SLEEP-MS 0 #;2000)
     51
     52;; Greedy Reader
     53
     54(define-thread reader-thread
    3555  (do ((n (hash-table-count/synch +tht+) (hash-table-count/synch +tht+)))
    36       ((fx= 20 n) (print "test hash-table count = " n " so quit"))
    37     (print "test hash-table count = " n) ) )
    38 (define reader-thread (make-thread reader 'reader))
    39 (thread-start! reader-thread)
     56      ((fx= READER-THREAD-LIMIT n)
     57        (print "test hash-table count = " n " so quit"))
     58    (print "test hash-table count = " n)
     59    (thread-sleep! THREAD-SLEEP-MS) ) )
    4060
    41 ;; Cooperative writer
     61;; Cooperative Writer
    4262
    43 (define (writer)
     63(define-thread writer-thread
    4464  (repeat* 10
    4565    (hash-table-set!/synch +tht+ it (number->string it))
    4666    (hash-table-set!/synch +tht+ (* it 11) (number->string it))
     67    (thread-sleep! THREAD-SLEEP-MS)
    4768    (thread-yield!) ) )
    48 (define writer-thread (make-thread writer 'writer))
    49 (thread-start! writer-thread)
    5069
    5170;;
    5271
     72(thread-start! writer-thread)
     73(thread-start! reader-thread)
     74
    5375(thread-join! writer-thread)
    5476(thread-join! reader-thread)
Note: See TracChangeset for help on using the changeset viewer.