Gauche:プロファイラ

プロファイラ

いずれは組込みでサポートしたいと思っていたところ、koguroさんがマクロで実装してしまいました。

koguroさん版

マクロの勉強をかねて、プロファイラを書いてみました。

;;
;; profiler.scm 
;; 

(use srfi-26)
(use gauche.time)

(define (make-stat) (cons 1 0))
(define (stat-count stat) (car stat))
(define (stat-elapse stat) (cdr stat))
(define (inc-stat-count stat) 
  (set-car! stat (+ (car stat) 1)))
(define (add-stat-elapse stat time) 
  (set-cdr! stat (+ (cdr stat) time)))

(define *symbol-table* (make-hash-table))
(define (symbol-table-put! proc v)
  (hash-table-put! *symbol-table* proc v))
(define (symbol-table-get proc)
  (hash-table-get *symbol-table* proc))

(define *profiler-table* (make-hash-table))
(define (inc-count v)
  (if (hash-table-exists? *profiler-table* v)
      (inc-stat-count (hash-table-get *profiler-table* v))
      (hash-table-put! *profiler-table* v (make-stat))))
(define (add-elapse v time)
  (if (hash-table-exists? *profiler-table* v)
      (add-stat-elapse (hash-table-get *profiler-table* v) time)
      (hash-table-put! *profiler-table* v (make-stat))))

(define (show-profile)
  (hash-table-map *profiler-table* 
                  (lambda (proc stat)
                    (format #t "~a ~a ~a~%" 
                            (stat-count stat)
                            (* 1000 (stat-elapse stat))
                            (symbol-table-get proc)))))

(define *define* define)
(define *lambda* lambda)

(define-syntax wrap 
  (syntax-rules ()
    ((wrap proc wrap-proc)
     (let ((proc proc)
           (apply apply))
       (*lambda* variables
                 (wrap-proc (*lambda* () (apply proc variables))))))))

(define (profile-function id proc)
  (let ((time-counter (make <real-time-counter>)))
    (inc-count id)
    (begin0
        (with-time-counter time-counter (proc))
      (add-elapse id (time-counter-value time-counter)))))

(define-syntax define
  (syntax-rules ()
    ((define (variable . formals) body ...)
     (begin
       (define variable (lambda formals body ...))))
    ((define variable expression) 
     (begin
       (*define* variable expression)
       (if (procedure? variable)
           (symbol-table-put! variable 'variable))))))

(define-syntax lambda
  (syntax-rules ()
    ((lambda formals body ...)
     (letrec ((proc (*lambda* formals body ...))
              (wrap-proc (wrap proc (cut profile-function wrap-proc <>))))
       (symbol-table-put! wrap-proc (format "~s" '(lambda formals body ...)))
       wrap-proc))))

(define-syntax profile
  (syntax-rules ()
    ((profile proc)
     (define proc
       (let ((proc proc))
         (lambda formals (apply proc formals)))))))

(*define* (main args)
          (*define* (main args) 0)
          (load (cadr args))
          (main (cdr args))
          (show-profile)
          0)

./profiler.scm ./tarai.scm のように実行すると、最後に

192
27649 441019.93199998135 tarai

実行回数、実行時間(ms)、関数名を表示します。ただしとても遅いです。なお、define, lambda で定義された関数が計測対象となります。プリミティブな関数を計測したいときは、(profile car) のように指定してください。

ありがとうございます。素晴らしい！ macroの威力ですね。私も勉強しようっと。sakae

Shiro (2003/05/03 03:56:45 PDT): おお、こんなことができるとは。いくつかコメント。
- 構文要素に束縛されている識別子を変数として参照した場合の振る舞いは R5RSでは未定義なので、(define *define* define) が動くかどうかは処理系依存です。
- また、define等のトップレベルの構文をdefine-syntaxで置き換えた場合の振る舞いもR5RS的には未定義です。
- (set-car! stat (+ (car stat) 1)) は Gaucheのマクロinc!を使って (inc! (car stat)) と書けます。
koguro (2003/05/03 05:13:04 PDT): コメントありがとうございます。構文要素の再定義は処理系依存でしたか。define とか lambda 自身を評価させると値が返ってきたので、これらも first-class object として扱えるものだと思っていました。

Gauche 0.8での問題

teranishi: Gauche0.8で実行すると、以下のエラーが出ます。

*** ERROR: *define* is used at non-toplevel: (*define* (main args) 0)

該当個所を (set! main (*lambda* (args) 0)) に直せば動きますが、内部defineのデータが取れません。

$ cat definetest.scm
(define (main args)
  (define (f x) 10)
  (f 20)
  0)
$ gosh profiler.scm definetest.scm
1 0 main

トップレベルでdefineを再定義しても、内部defineには反映されないようです。

Shiro: 内部defineに関しては、0.8以前から「マクロ展開の結果生成される内部defineが内部defineとして認識されない」というバグがありました。ただ、0.8以前はそれがトップレベルdefineとして認識されるという別のバグがあり、そのせいで前のバグが見えていなかったのだと思います。

teranishi版

koguroさん版で、lambda式を評価するたびに別の関数としてカウントされるのが個人的に使いづらかったので、手を加えさせていただきました。

(use gauche.time)
(use util.match)

(define *profiler-table* ())

(define (make-profile-function name)
  (let ((count 0)
        (time (make <real-time-counter>)))
    (push! *profiler-table*
           (lambda ()
             (format #t "~a ~a ~s~%" count (* 1000 (time-counter-value time)) name)))
    (let ((before (lambda () (time-counter-start! time)))
          (after (lambda () (time-counter-stop! time))))
      (lambda (proc)
        (inc! count)
        (dynamic-wind before proc after)))))

(define (show-profile)
  (for-each (lambda (f) (f)) *profiler-table*))

(define *define* define)
(define *lambda* lambda)

(define-macro (profile proc)
  (let ((profile-function (make-profile-function proc)))
    `(*define* ,proc
       (let ((original ,proc))
         (*lambda* args (,profile-function (*lambda* () (,apply original args))))))))

(define-macro (define . rest)
  (match rest
    ((or ((variable . formals) body ...) (variable ('lambda formals body ...)))
     (let ((profile-function (make-profile-function variable)))
       `(*define* (,variable . ,formals) (,profile-function (*lambda* () ,@body)))))
    ((variable expression)
     `(*define* ,variable ,expression))))

(define-macro (lambda formals . body)
  (let ((profile-function (make-profile-function (list* 'lambda formals body))))
    `(*lambda* ,formals (,profile-function (*lambda* () ,@body)))))

(*define* (main args)
          (set! main (*lambda* (args) 0))
          (load (cadr args))
          (main (cdr args))
          (show-profile)
          0)