This is the mail archive of the guile@sources.redhat.com mailing list for the Guile project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]

Re: Scheme profiler?


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))))))))

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]