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