From 9ca1ab7ccc742f8178d984c01bde23e4a8a0aa76 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 5 Nov 2009 01:36:26 -0600
Subject: [PATCH] tools.dispatch: split off method dispatch statistics from
 tools.time

---
 basis/tools/dispatch/authors.txt          |  1 +
 basis/tools/dispatch/dispatch-docs.factor |  8 ++++++++
 basis/tools/dispatch/dispatch.factor      | 24 +++++++++++++++++++++++
 3 files changed, 33 insertions(+)
 create mode 100644 basis/tools/dispatch/authors.txt
 create mode 100644 basis/tools/dispatch/dispatch-docs.factor
 create mode 100644 basis/tools/dispatch/dispatch.factor

diff --git a/basis/tools/dispatch/authors.txt b/basis/tools/dispatch/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/tools/dispatch/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/tools/dispatch/dispatch-docs.factor b/basis/tools/dispatch/dispatch-docs.factor
new file mode 100644
index 0000000000..e93ea165c1
--- /dev/null
+++ b/basis/tools/dispatch/dispatch-docs.factor
@@ -0,0 +1,8 @@
+IN: tools.dispatch
+USING: help.markup help.syntax vm quotations ;
+
+HELP: last-dispatch-stats
+{ $var-description "A " { $link dispatch-statistics } " instance, set by " { $link collect-dispatch-stats } "." } ;
+
+HELP: dispatch-stats.
+{ $description "Prints method dispatch statistics from the last call to " { $link collect-dispatch-stats } "." } ;
diff --git a/basis/tools/dispatch/dispatch.factor b/basis/tools/dispatch/dispatch.factor
new file mode 100644
index 0000000000..7d30dac36b
--- /dev/null
+++ b/basis/tools/dispatch/dispatch.factor
@@ -0,0 +1,24 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces prettyprint classes.struct
+vm tools.dispatch.private ;
+IN: tools.dispatch
+
+SYMBOL: last-dispatch-stats
+
+: dispatch-stats. ( -- )
+    last-dispatch-stats get {
+        { "Megamorphic hits" [ megamorphic-cache-hits>> ] }
+        { "Megamorphic misses" [ megamorphic-cache-misses>> ] }
+        { "Cold to monomorphic" [ cold-call-to-ic-transitions>> ] }
+        { "Mono to polymorphic" [ ic-to-pic-transitions>> ] }
+        { "Poly to megamorphic" [ pic-to-mega-transitions>> ] }
+        { "Tag check count" [ pic-tag-count>> ] }
+        { "Tuple check count" [ pic-tuple-count>> ] }
+    } object-table. ;
+
+: collect-dispatch-stats ( quot -- )
+    reset-dispatch-stats
+    call
+    dispatch-stats dispatch-statistics memory>struct
+    last-dispatch-stats set ; inline