suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: fix PLT_LINKLET_TIMES mode Racket-thread safety

Browse Source
This commit is contained in:
Matthew Flatt 2018-07-02 07:20:44 -06:00
parent eea40a6350
commit a2f1f11f9b
1 changed files with 22 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
racket/src/cs/linklet/performance.ss
View File

@ -6,6 +6,10 @@
(define current-start-time '()) (define current-start-time '())
(define current-gc-start-time '()) (define current-gc-start-time '())
;; Beware that `performance-region` doesn't really handle escapes, and
;; Racket-level thread swaps during `performance-region` can cause
;; strange results.
(define-syntax performance-region (define-syntax performance-region
(syntax-rules () (syntax-rules ()
[(_ label e ...) (measure-performance-region label (lambda () e ...))])) [(_ label e ...) (measure-performance-region label (lambda () e ...))]))
@ -13,27 +17,30 @@
(define (measure-performance-region label thunk) (define (measure-performance-region label thunk)
(cond (cond
[measure-performance? [measure-performance?
(set! current-start-time (cons (current-process-milliseconds) current-start-time)) (with-interrupts-disabled
(set! current-gc-start-time (cons (current-gc-milliseconds) current-gc-start-time)) (set! current-start-time (cons (current-process-milliseconds) current-start-time))
(set! current-gc-start-time (cons (current-gc-milliseconds) current-gc-start-time)))
(begin0 (begin0
(thunk) (thunk)
(let ([delta (- (current-process-milliseconds) (car current-start-time))] (with-interrupts-disabled
[gc-delta (- (current-gc-milliseconds) (car current-gc-start-time))]) (let ([delta (- (current-process-milliseconds) (car current-start-time))]
(hashtable-update! region-times label (lambda (v) (+ v delta)) 0) [gc-delta (- (current-gc-milliseconds) (car current-gc-start-time))])
(hashtable-update! region-gc-times label (lambda (v) (+ v gc-delta)) 0) (hashtable-update! region-times label (lambda (v) (+ v delta)) 0)
(hashtable-update! region-counts label add1 0) (hashtable-update! region-gc-times label (lambda (v) (+ v gc-delta)) 0)
(set! current-start-time (cdr current-start-time)) (hashtable-update! region-counts label add1 0)
(set! current-gc-start-time (cdr current-gc-start-time)) (set! current-start-time (cdr current-start-time))
(let loop ([l current-start-time] [gc-l current-gc-start-time]) (set! current-gc-start-time (cdr current-gc-start-time))
(unless (null? l) (let loop ([l current-start-time] [gc-l current-gc-start-time])
(set-car! l (+ (car l) delta)) (unless (null? l)
(set-car! gc-l (+ (car gc-l) gc-delta)) (set-car! l (+ (car l) delta))
(loop (cdr l) (cdr gc-l))))))] (set-car! gc-l (+ (car gc-l) gc-delta))
(loop (cdr l) (cdr gc-l)))))))]
[else (thunk)])) [else (thunk)]))
(define (add-performance-memory! label delta) (define (add-performance-memory! label delta)
(when measure-performance? (when measure-performance?
(hashtable-update! region-memories label (lambda (v) (+ v delta)) 0))) (with-interrupts-disabled
(hashtable-update! region-memories label (lambda (v) (+ v delta)) 0))))
(define (linklet-performance-init!) (define (linklet-performance-init!)
(hashtable-set! region-times 'boot (hashtable-set! region-times 'boot