This is the mail archive of the
guile@sources.redhat.com
mailing list for the Guile project.
Re: Scheme profiler?
- To: guile at sourceware dot cygnus dot com
- Subject: Re: Scheme profiler?
- From: Keisuke Nishida <kxn30 at po dot cwru dot edu>
- Date: 15 Jul 2000 22:42:10 -0400
- References: <m37lan823o.fsf@indy.cwru.edu>
I wrote:
> Is there any Scheme code profiler that works with Guile?
> It seems Guile's core (libguile/eval.c) has no such code in it.
> Is it a good idea to work on this? (I guess the debug evaluator
> may have such facilities...)
This is actually fairly easy. Even the patch below gives some
useful information:
% guile
guile> (set! *profile-all* #t)
guile> (use-modules (oop goops))
guile> (load "profile.scm")
Called Procedure Run Real
------ --------- --- ----
2 read 0 658
12 dynamic-wind 183 183
2299 for-each 101 102
1775 eval 99 99
5 try-load-module 85 86
6 try-module-autoload 85 85
5 primitive-load 82 82
252 map 49 49
2294 hash-fold 46 41
5 process-define-module 37 35
1674 scm-module-closure 32 32
1265 module-local-variable 13 19
2 dynamic-call 19 19
11483 eq? 14 18
(snip)
Could similar codes be included in the core?
Thanks,
Keisuke Nishida
Index: eval.c
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/eval.c,v
retrieving revision 1.166
diff -u -r1.166 eval.c
--- eval.c 2000/06/21 02:42:03 1.166
+++ eval.c 2000/07/16 02:34:21
@@ -93,6 +93,8 @@
#include "libguile/srcprop.h"
#include "libguile/stackchk.h"
#include "libguile/objects.h"
+#include "libguile/objprop.h"
+#include "libguile/stime.h"
#include "libguile/async.h"
#include "libguile/feature.h"
#include "libguile/modules.h"
@@ -1793,6 +1795,9 @@
#ifndef DEVAL
#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
+
+SCM_SYMBOL (sym_profile_data, "profile-data");
+SCM_VCELL_INIT (scm_profile_all, "*profile-all*", SCM_BOOL_F);
#endif /* DEVAL */
#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
@@ -1824,6 +1829,8 @@
} t;
SCM proc, arg2;
#ifdef DEVAL
+ SCM prof_data = SCM_BOOL_F;
+ SCM prof_obj, prof_run, prof_real;
scm_debug_frame debug;
scm_debug_info *debug_info_end;
debug.prev = scm_last_debug_frame;
@@ -2628,6 +2635,21 @@
evapply:
PREP_APPLY (proc, SCM_EOL);
+#ifdef DEVAL
+ /* Start profiling */
+ prof_data = scm_object_property (proc, sym_profile_data);
+ if (SCM_NFALSEP (SCM_CDR (scm_profile_all)) || SCM_NFALSEP (prof_data))
+ {
+ prof_obj = proc;
+ prof_run = scm_get_internal_run_time ();
+ prof_real = scm_get_internal_real_time ();
+ if (!SCM_VECTORP (prof_data) || SCM_LENGTH (prof_data) != 3)
+ {
+ prof_data = scm_make_vector (SCM_MAKINUM (3), SCM_MAKINUM (0));
+ scm_set_object_property_x (proc, sym_profile_data, prof_data);
+ }
+ }
+#endif
if (SCM_NULLP (SCM_CDR (x))) {
ENTER_APPLY;
evap0:
@@ -3188,6 +3210,16 @@
scm_ithrow (scm_sym_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0);
}
ret:
+ /* Finish profiling */
+ if (SCM_NFALSEP (prof_data))
+ {
+ prof_run = scm_difference (scm_get_internal_run_time (), prof_run);
+ prof_real = scm_difference (scm_get_internal_real_time (), prof_real);
+ SCM_VELTS (prof_data)[0] =
+ scm_sum (SCM_VELTS (prof_data)[0], SCM_MAKINUM (1));
+ SCM_VELTS (prof_data)[1] = scm_sum (SCM_VELTS (prof_data)[1], prof_run);
+ SCM_VELTS (prof_data)[2] = scm_sum (SCM_VELTS (prof_data)[2], prof_real);
+ }
scm_last_debug_frame = debug.prev;
return proc;
#endif
@@ -3271,6 +3303,8 @@
{
#ifdef DEBUG_EXTENSIONS
#ifdef DEVAL
+ SCM prof_data = SCM_BOOL_F;
+ SCM prof_obj, prof_run, prof_real;
scm_debug_frame debug;
scm_debug_info debug_vect_body;
debug.prev = scm_last_debug_frame;
@@ -3340,6 +3374,21 @@
scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0);
}
entap:
+#ifdef DEVAL
+ /* Start profiling */
+ prof_data = scm_object_property (proc, sym_profile_data);
+ if (SCM_NFALSEP (SCM_CDR (scm_profile_all)) || SCM_NFALSEP (prof_data))
+ {
+ prof_obj = proc;
+ prof_run = scm_get_internal_run_time ();
+ prof_real = scm_get_internal_real_time ();
+ if (!SCM_VECTORP (prof_data) || SCM_LENGTH (prof_data) != 3)
+ {
+ prof_data = scm_make_vector (SCM_MAKINUM (3), SCM_MAKINUM (0));
+ scm_set_object_property_x (proc, sym_profile_data, prof_data);
+ }
+ }
+#endif
ENTER_APPLY;
#endif
#ifdef CCLO
@@ -3555,6 +3604,16 @@
scm_ithrow (scm_sym_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0);
}
ret:
+ /* Finish profiling */
+ if (SCM_NFALSEP (prof_data))
+ {
+ prof_run = scm_difference (scm_get_internal_run_time (), prof_run);
+ prof_real = scm_difference (scm_get_internal_real_time (), prof_real);
+ SCM_VELTS (prof_data)[0] =
+ scm_sum (SCM_VELTS (prof_data)[0], SCM_MAKINUM (1));
+ SCM_VELTS (prof_data)[1] = scm_sum (SCM_VELTS (prof_data)[1], prof_run);
+ SCM_VELTS (prof_data)[2] = scm_sum (SCM_VELTS (prof_data)[2], prof_real);
+ }
scm_last_debug_frame = debug.prev;
return proc;
#endif
;;; profile.scm
(use-modules (ice-9 session) (ice-9 format))
(let ((procs (let loop ((vals (map eval (apropos-internal "")))
(procs '()))
(if (null? vals)
procs
(let ((proc (car vals))
(data (object-property (car vals) 'profile-data)))
(if data
(loop (cdr vals) (acons proc data procs))
(loop (cdr vals) procs)))))))
(display "Called Procedure Run Real\n")
(display "------ --------- --- ----\n")
(map (lambda (p)
(let ((proc (car p)) (data (cdr p)))
(format #t "~6a ~32a ~4a ~4a~%"
(vector-ref data 0)
(procedure-name proc)
(vector-ref data 1)
(vector-ref data 2))))
(let ((real (lambda (p) (vector-ref (cdr p) 2)))
(count (lambda (p) (vector-ref (cdr p) 0))))
(sort! procs (lambda (p1 p2)
(if (= (real p1) (real p2))
(> (count p1) (count p2))
(> (real p1) (real p2))))))))