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

cs: reduce PLT_LINKLET_TIMES overhead

Browse Source
This commit is contained in:
Matthew Flatt 2019-06-11 16:42:44 -06:00
parent 41dc6f1335
commit b1632232ca
1 changed files with 129 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,10 +1,9 @@
(define region-times (make-eq-hashtable)) (define perf-regions (make-eq-hashtable))
(define region-gc-times (make-eq-hashtable)) (define-record perf-region (time gc-time count memory))
(define region-counts (make-eq-hashtable))
(define region-memories (make-eq-hashtable))
(define current-start-time '()) (define current-perf-frame #f)
(define current-gc-start-time '())
(define-record perf-frame (start gc-start nested-delta nested-gc-delta next))
(define performance-thread-id (get-thread-id)) (define performance-thread-id (get-thread-id))
@ -37,41 +36,62 @@
(syntax-rules () (syntax-rules ()
[(_ label e ...) (measure-performance-region label (lambda () e ...))])) [(_ label e ...) (measure-performance-region label (lambda () e ...))]))
(define (label->perf-region label)
(or (hashtable-ref perf-regions label #f)
(let ([r (make-perf-region 0 0 0 0)])
(hashtable-set! perf-regions label r)
r)))
(define (measure-performance-region label thunk) (define (measure-performance-region label thunk)
(cond (cond
[(and measure-performance? [(and measure-performance?
(eqv? (get-thread-id) performance-thread-id)) (eqv? (get-thread-id) performance-thread-id))
(with-interrupts-disabled (set! current-perf-frame (make-perf-frame (current-process-milliseconds)
(set! current-start-time (cons (current-process-milliseconds) current-start-time)) (current-gc-milliseconds)
(set! current-gc-start-time (cons (current-gc-milliseconds) current-gc-start-time))) 0
0
current-perf-frame))
(begin0 (begin0
(thunk) (thunk)
(with-interrupts-disabled (let ([f current-perf-frame])
(let ([delta (- (current-process-milliseconds) (car current-start-time))] (when f ; avoid crash if thread swaps mangle stack update
[gc-delta (- (current-gc-milliseconds) (car current-gc-start-time))]) (let ([delta (- (current-process-milliseconds) (perf-frame-start f) (perf-frame-nested-delta f))]
(hashtable-update! region-times label (lambda (v) (+ v delta)) 0) [gc-delta (- (current-gc-milliseconds) (perf-frame-gc-start f) (perf-frame-nested-gc-delta f))]
(hashtable-update! region-gc-times label (lambda (v) (+ v gc-delta)) 0) [r (label->perf-region label)])
(hashtable-update! region-counts label add1 0) (set-perf-region-time! r (+ (perf-region-time r) delta))
(set! current-start-time (cdr current-start-time)) (set-perf-region-gc-time! r (+ (perf-region-gc-time r) gc-delta))
(set! current-gc-start-time (cdr current-gc-start-time)) (set-perf-region-count! r (+ (perf-region-count r) 1))
(let loop ([l current-start-time] [gc-l current-gc-start-time]) (let ([next (perf-frame-next f)])
(unless (null? l) (set! current-perf-frame next)
(set-car! l (+ (car l) delta)) (when next
(set-car! gc-l (+ (car gc-l) gc-delta)) (set-perf-frame-nested-delta! next (+ delta (perf-frame-nested-delta f) (perf-frame-nested-delta next)))
(loop (cdr l) (cdr gc-l)))))))] (set-perf-frame-nested-gc-delta! next (+ gc-delta (perf-frame-nested-gc-delta f) (perf-frame-nested-gc-delta next)))))))))]
[else (thunk)])) [else (thunk)]))
(define (add-performance-memory! label delta) (define (add-performance-memory! label delta)
(when measure-performance? (when measure-performance?
(with-interrupts-disabled (with-interrupts-disabled
(hashtable-update! region-memories label (lambda (v) (+ v delta)) 0)))) (let ([r (label->perf-region label)])
(set-perf-region-memory! r (+ (perf-region-memory r) delta))))))
(define (linklet-performance-init!) (define (linklet-performance-init!)
(hashtable-set! region-times 'boot (let ([r (label->perf-region 'boot)])
(time->ms (sstats-cpu (statistics))))) (set-perf-region-time! r (time->ms (sstats-cpu (statistics))))))
(define (linklet-performance-report!) (define (linklet-performance-report!)
(when measure-performance? (when measure-performance?
(let ([region-times (make-eq-hashtable)]
[region-gc-times (make-eq-hashtable)]
[region-counts (make-eq-hashtable)]
[region-memories (make-eq-hashtable)])
(hash-table-for-each perf-regions
(lambda (k r)
(hashtable-set! region-times k (perf-region-time r))
(hashtable-set! region-gc-times k (perf-region-gc-time r))
(hashtable-set! region-counts k (perf-region-count r))
(let ([m (perf-region-memory r)])
(unless (zero? m)
(hashtable-set! region-memories k m)))))
(for-each (lambda (s) (for-each (lambda (s)
(let ([label (if (#%memq (car s) register-allocation-passes) (let ([label (if (#%memq (car s) register-allocation-passes)
'regalloc 'regalloc
@ -155,4 +175,4 @@
(report 0 'total total (#%format " [~a]" gc-total) 'ms "") (report 0 'total total (#%format " [~a]" gc-total) 'ms "")
(lprintf ";;") (lprintf ";;")
(for-each (lambda (p) (report 0 (car p) (/ (cdr p) 1024 1024) "" 'MB "")) (for-each (lambda (p) (report 0 (car p) (/ (cdr p) 1024 1024) "" 'MB ""))
(ht->sorted-list region-memories))))) (ht->sorted-list region-memories))))))