*** empty log message ***
[bpt/guile.git] / module / system / vm / profile.scm
CommitLineData
17e90c5e
KN
1;;; Guile VM profiler
2
3;; Copyright (C) 2001 Free Software Foundation, Inc.
4
5;; This program is free software; you can redistribute it and/or modify
6;; it under the terms of the GNU General Public License as published by
7;; the Free Software Foundation; either version 2, or (at your option)
8;; any later version.
9;;
10;; This program is distributed in the hope that it will be useful,
11;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13;; GNU General Public License for more details.
14;;
15;; You should have received a copy of the GNU General Public License
16;; along with this program; see the file COPYING. If not, write to
17;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18;; Boston, MA 02111-1307, USA.
19
20;;; Code:
21
22(define-module (system vm profile)
23 :use-module (system vm core)
24 :use-module (ice-9 format)
25 :export (vm-profile))
26
8f5cfc81 27(define (vm-profile vm objcode . opts)
17e90c5e
KN
28 (let ((flag (vm-option vm 'debug)))
29 (dynamic-wind
30 (lambda ()
31 (set-vm-option! vm 'debug #t)
32 (set-vm-option! vm 'profile-data '())
33 (add-hook! (vm-next-hook vm) profile-next)
34 (add-hook! (vm-enter-hook vm) profile-enter)
35 (add-hook! (vm-exit-hook vm) profile-exit))
36 (lambda ()
ac99cb0c 37 (let ((val (vm-load vm objcode)))
17e90c5e
KN
38 (display-result vm)
39 val))
40 (lambda ()
41 (set-vm-option! vm 'debug flag)
42 (remove-hook! (vm-next-hook vm) profile-next)
43 (remove-hook! (vm-enter-hook vm) profile-enter)
44 (remove-hook! (vm-exit-hook vm) profile-exit)))))
45
46(define (profile-next vm)
47 (set-vm-option! vm 'profile-data
48 (cons (vm-fetch-code vm) (vm-option vm 'profile-data))))
49
50(define (profile-enter vm)
51 #f)
52
53(define (profile-exit vm)
54 #f)
55
56(define (display-result vm . opts)
57 (do ((data (vm-option vm 'profile-data) (cdr data))
58 (summary '() (let ((inst (caar data)))
59 (assq-set! summary inst
60 (1+ (or (assq-ref summary inst) 0))))))
61 ((null? data)
62 (display "Count Instruction\n")
63 (display "----- -----------\n")
64 (for-each (lambda (entry)
65 (format #t "~5@A ~A\n" (cdr entry) (car entry)))
66 (sort summary (lambda (e1 e2) (> (cdr e1) (cdr e2))))))))