From bacc7d9399aa6d727709beefcfb5429a1deb7bfe Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sun, 3 Jul 2011 21:00:11 +0900
Subject: [PATCH] adding simple VM-level profiler

---
 eval.c                   |  5 +++++
 include/chibi/features.h |  4 ++++
 opcodes.c                |  4 ++++
 vm.c                     | 37 +++++++++++++++++++++++++++++++++++--
 4 files changed, 48 insertions(+), 2 deletions(-)

diff --git a/eval.c b/eval.c
index d96949b5..1cdf845b 100644
--- a/eval.c
+++ b/eval.c
@@ -1467,6 +1467,11 @@ sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp typ
 
 #endif
 
+#if SEXP_USE_PROFILE_VM
+static sexp sexp_reset_vm_profile (sexp ctx sexp_api_params(self, n));
+static sexp sexp_print_vm_profile (sexp ctx sexp_api_params(self, n));
+#endif
+
 #include "opcodes.c"
 
 static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) {
diff --git a/include/chibi/features.h b/include/chibi/features.h
index ae762fe4..362c7b96 100644
--- a/include/chibi/features.h
+++ b/include/chibi/features.h
@@ -414,6 +414,10 @@
 #define SEXP_USE_DEBUG_VM 0
 #endif
 
+#ifndef SEXP_USE_PROFILE_VM
+#define SEXP_USE_PROFILE_VM 0
+#endif
+
 #ifndef SEXP_USE_UTF8_STRINGS
 #define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES
 #endif
diff --git a/opcodes.c b/opcodes.c
index 80598f17..4d775654 100644
--- a/opcodes.c
+++ b/opcodes.c
@@ -183,6 +183,10 @@ _FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, se
 #if SEXP_USE_GREEN_THREADS
 _OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_VOID, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, 0, "yield!", 0, NULL),
 #endif
+#if SEXP_USE_PROFILE_VM
+_FN0(SEXP_VOID, "reset-vm-profile", 0, sexp_reset_vm_profile),
+_FN0(SEXP_VOID, "print-vm-profile", 0, sexp_print_vm_profile),
+#endif
 #if SEXP_USE_AUTO_FORCE
 _FN1(_I(SEXP_PROMISE), _I(SEXP_PROCEDURE), "make-promise", 0, sexp_make_promise),
 #endif
diff --git a/vm.c b/vm.c
index 7e52fe39..7d14e024 100644
--- a/vm.c
+++ b/vm.c
@@ -621,7 +621,7 @@ static int sexp_check_type(sexp ctx, sexp a, sexp b) {
   top -= i; _ARG1 = x; ip += sizeof(sexp); sexp_check_exception();
 #endif
 
-#if SEXP_USE_DEBUG_VM
+#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM
 #include "opt/opcode_names.h"
 #endif
 
@@ -629,6 +629,31 @@ static int sexp_check_type(sexp ctx, sexp a, sexp b) {
 #include "opt/fcall.c"
 #endif
 
+#if SEXP_USE_PROFILE_VM
+sexp_uint_t profile1[SEXP_OP_NUM_OPCODES];
+sexp_uint_t profile2[SEXP_OP_NUM_OPCODES][SEXP_OP_NUM_OPCODES];
+
+static sexp sexp_reset_vm_profile (sexp ctx sexp_api_params(self, n)) {
+  int i, j;
+  for (i=0; i<SEXP_OP_NUM_OPCODES; i++) {
+    profile1[i] = 0;
+    for (j=0; j<SEXP_OP_NUM_OPCODES; j++) profile2[i][j] = 0;
+  }
+  return SEXP_VOID;
+}
+
+static sexp sexp_print_vm_profile (sexp ctx sexp_api_params(self, n)) {
+  int i, j;
+  for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
+    fprintf(stderr, "%s %lu\n", reverse_opcode_names[i], profile1[i]);
+  for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
+    for (j=0; j<SEXP_OP_NUM_OPCODES; j++)
+      fprintf(stderr, "%s %s %lu\n", reverse_opcode_names[i],
+              reverse_opcode_names[j], profile2[i][j]);
+  return SEXP_VOID;
+}
+#endif
+
 sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
   unsigned char *ip;
   sexp bc, cp, *stack = sexp_stack_data(sexp_context_stack(ctx));
@@ -637,6 +662,9 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
   sexp root_thread = ctx;
   sexp_sint_t fuel = sexp_context_refuel(ctx);
 #endif
+#if SEXP_USE_PROFILE_VM
+  unsigned char last_op = SEXP_OP_NOOP;
+#endif
 #if SEXP_USE_BIGNUMS
   sexp_lsint_t prod;
 #endif
@@ -684,6 +712,11 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
              ? sexp_opcode_name(((sexp*)(ip+1))[0]) : ""),
             ip, stack, top, fp, (fp<1024 ? sexp_unbox_fixnum(stack[fp+3]) : -1));
   }
+#endif
+#if SEXP_USE_PROFILE_VM
+  profile1[*ip]++;
+  profile2[last_op][*ip]++;
+  last_op = *ip;
 #endif
   switch (*ip++) {
   case SEXP_OP_NOOP:
@@ -1606,7 +1639,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
 sexp sexp_apply1 (sexp ctx, sexp f, sexp x) {
   sexp res;
   sexp_gc_var1(args);
-  if (sexp_opcodep(f)) {
+  if (sexp_opcodep(f) && sexp_opcode_func(f)) {
     res = ((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), x);
   } else {
     sexp_gc_preserve1(ctx, args);