Changeset 13480 in project for release/4/synch
- Timestamp:
- 03/04/09 02:07:27 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/synch/trunk/synch.scm
r13474 r13480 70 70 ;;; 71 71 72 (define-for-syntax (recmuxnam nam) 73 (string->symbol (conc nam #\- 'mutex)) ) 74 75 ;;; 76 72 77 (define (make-object/synch obj #!optional (name '(synchobj))) 73 78 (let ([mutex (make-mutex (if (pair? name) (gensym (car name)) name))]) … … 108 113 [$mutex-unlock! (r 'mutex-unlock!)] 109 114 [$mutex-specific (r 'mutex-specific)] 110 [$mutex-lock! (r 'mutex-lock!)] )111 (let ([mtxvar (gensym)]112 115 [$mutex-lock! (r 'mutex-lock!)] 116 [mtxvar (r (gensym))]) 117 (let ([?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)]) 113 118 `(,$let ([,mtxvar ,?mtx]) 114 119 (,$let ([,?var (,$mutex-specific ,mtxvar)]) … … 175 180 [$begin (r 'begin)]) 176 181 (let ([?bnd (cadr form)] [?body (cddr form)]) 177 (let ([?var (car ?bnd)] 178 [?mtx (cadr ?bnd)]) 182 (let ([?var (car ?bnd)] [?mtx (cadr ?bnd)]) 179 183 `(,$synch-with ,?mtx ,?var 180 184 (,$mutex-specific-set! ,?mtx (,$begin ,@?body)) 181 185 (,$mutex-specific ,?mtx) ) ) ) ) ) ) 182 186 187 #; ;Since not capturing anything shouldn't need to do this 183 188 (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 184 211 (syntax-rules () 185 212 [(_ ?mtx ?body ...) 186 213 (let ([mtx ?mtx] [ok? #f]) 187 (dynamic-wind 214 (mutex-lock! mtx) 215 (dynamic-wind 188 216 (lambda () (mutex-lock! mtx)) 189 190 (lambda () (unless ok? (mutex-unlock! mtx)))) ) ] ) )217 (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res)) 218 (lambda () (unless ok? (mutex-unlock! mtx)))) ) ] ) ) 191 219 192 220 (define-syntax synch/unlock … … 205 233 (lambda (form r c) 206 234 (##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)) ) ) ) ) ) 232 257 233 258 (define-syntax record/synch … … 236 261 (let ([$synch (r 'synch)]) 237 262 (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) ) ) ) ) 239 264 240 265 (define-syntax record-synch/lock … … 243 268 (let ([$synch/lock (r 'synch/lock)]) 244 269 (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) ) ) ) ) 246 271 247 272 (define-syntax record-synch/unlock … … 250 275 (let ([$synch/unlock (r 'synch/unlock)]) 251 276 (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) ) ) ) ) 253 278 254 279 ;;; Unprotected … … 266 291 267 292 (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)) ) ) ) ) ) ) ) 281 314 282 315 (define-syntax %synch … … 305 338 306 339 (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 ) ) ) ) ) ) ) 320 351 321 352 (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) ) ) ) ) ) ) ) 332 367 333 368 (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]) 340 372 (mutex-lock! mtx) 341 373 (call-with-values … … 343 375 (lambda ret 344 376 (unless ok? (mutex-unlock! mtx)) 345 (apply values ret))) ) )) )377 (apply values ret))) ) ] ) ) 346 378 347 379 (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)) ) ) ] ) ) 362 391 363 392 (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)) ) ) ) ) ) 389 417 390 418 (define-syntax %record/synch 391 419 (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 ...) ) ) ) ) 398 424 399 425 (define-syntax %record-synch/lock 400 426 (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) ) ) ) ) 407 431 408 432 (define-syntax %record-synch/unlock 409 433 (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) ) ) ) ) 416 438 417 439 ) ;module synch
Note: See TracChangeset
for help on using the changeset viewer.