109 lines
4.0 KiB
Racket
109 lines
4.0 KiB
Racket
#lang racket/base
|
|
|
|
(provide profile-thunk profile)
|
|
|
|
(require "sampler.rkt" (except-in "analyzer.rkt" profile)
|
|
(prefix-in text: "render-text.rkt")
|
|
(for-syntax racket/base))
|
|
|
|
(define (profile-thunk thunk
|
|
#:delay [delay 0.05]
|
|
#:repeat [rpt 1]
|
|
#:threads [threads? #f]
|
|
#:render [renderer text:render]
|
|
#:periodic-renderer [periodic-renderer #f]
|
|
#:use-errortrace? [et? #f]
|
|
#:order [order 'topological])
|
|
(unless (member order '(topological self total))
|
|
(raise-argument-error
|
|
'profile-thunk "(or/c 'topological 'self 'total)" order))
|
|
(define (call-renderer renderer profile)
|
|
(if (procedure-arity-includes? renderer 2)
|
|
(renderer profile order)
|
|
(renderer profile)))
|
|
(define cust (and threads? (make-custodian (current-custodian))))
|
|
(define sampler (create-sampler (if threads?
|
|
(list cust (current-thread))
|
|
(current-thread))
|
|
delay
|
|
#:use-errortrace? et?))
|
|
(define periodic-thread
|
|
(and periodic-renderer
|
|
(let ([delay (car periodic-renderer)]
|
|
[renderer (cadr periodic-renderer)])
|
|
(define (loop)
|
|
(sleep delay)
|
|
(call-renderer renderer (analyze-samples (sampler 'get-snapshots)))
|
|
(loop))
|
|
(thread loop))))
|
|
(define (run) (for/last ([i (in-range rpt)]) (thunk)))
|
|
(begin0 (with-handlers ([void (λ (e) (eprintf "profiled thunk error: ~a\n"
|
|
(if (exn? e)
|
|
(exn-message e)
|
|
(format "~e" e))))])
|
|
(if threads?
|
|
(parameterize ([current-custodian cust]) (run))
|
|
(run)))
|
|
(when periodic-thread (kill-thread periodic-thread))
|
|
(sampler 'stop)
|
|
(call-renderer renderer (analyze-samples (sampler 'get-snapshots)))))
|
|
|
|
(define-syntax (profile stx)
|
|
(syntax-case stx ()
|
|
[(_ x ...)
|
|
(let loop ([expr #f] [kwds '()] [xs (syntax->list #'(x ...))])
|
|
(cond
|
|
[(null? xs)
|
|
(if expr
|
|
(with-syntax ([expr expr] [kwds (reverse kwds)])
|
|
#'(profile-thunk (λ () expr) . kwds))
|
|
(raise-syntax-error 'profile "missing expression" stx))]
|
|
[(keyword? (syntax-e (car xs)))
|
|
(if (pair? (cdr xs))
|
|
(loop expr (list* (cadr xs) (car xs) kwds) (cddr xs))
|
|
;; let #%app throw the error
|
|
(loop expr (cons (car xs) kwds) (cdr xs)))]
|
|
[expr (raise-syntax-error 'profile "redundant expresion given"
|
|
stx (car xs))]
|
|
[else (loop (car xs) kwds (cdr xs))]))]))
|
|
|
|
#|
|
|
|
|
(define (fib1 n) (if (<= n 1) n (+ (fib1 (- n 1)) (fib1 (- n 2)))))
|
|
(define (fib22 n) (if (<= n 2) 1 (+ (fib22 (- n 1)) (fib22 (- n 2)))))
|
|
(define (fib3 n)
|
|
(for ([i (in-range 100000000)]) (* i 3))
|
|
(if (<= n 2) 1 (+ (fib22 (- n 1)) (fib22 (- n 2)))))
|
|
(define (fibs n) (+ (fib1 n) (fib22 n) (fib3 n)))
|
|
|
|
(define (foo n)
|
|
(define ch (make-channel))
|
|
(define (bg-fib) (channel-put ch (fib1 n)))
|
|
(thread bg-fib)
|
|
(list (fibs n) (channel-get ch)))
|
|
|
|
(require "render-graphviz.rkt")
|
|
|
|
(profile ;(fibs 40)
|
|
;(dynamic-require '(lib "scribblings/reference/reference.scrbl") #f)
|
|
(foo 40)
|
|
;#:render render
|
|
#:threads #t
|
|
#:periodic-renderer
|
|
(list 0.5 text:render)
|
|
)
|
|
|#
|
|
|
|
(module+ test
|
|
(require rackunit racket/string racket/list)
|
|
;; `profile' and `profile-thunk' should return the value of the
|
|
;; profiled expression
|
|
(check-equal?
|
|
(profile (for/last ([i (in-range 1000 5 -1)])
|
|
(string-join (map number->string (range i)))))
|
|
"0 1 2 3 4 5")
|
|
(check-equal?
|
|
(profile-thunk (lambda () (for/last ([i (in-range 1000 5 -1)])
|
|
(string-join (map number->string (range i))))))
|
|
"0 1 2 3 4 5"))
|