From c41a0cf6a226300a24c88a4ea9f1ebc81925a5d7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 6 Dec 2008 00:20:49 -0600
Subject: [PATCH] Add new words to tools.annotations to annotate words with
 timing code

---
 .../tools/annotations/annotations-docs.factor | 18 +++++++++++
 .../annotations/annotations-tests.factor      |  2 +-
 basis/tools/annotations/annotations.factor    | 30 +++++++++++++++----
 3 files changed, 44 insertions(+), 6 deletions(-)

diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor
index c61b4547a9..acb6d6dd2a 100644
--- a/basis/tools/annotations/annotations-docs.factor
+++ b/basis/tools/annotations/annotations-docs.factor
@@ -4,9 +4,17 @@ IN: tools.annotations
 
 ARTICLE: "tools.annotations" "Word annotations"
 "The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question."
+$nl
+"Printing messages when a word is called or returns:"
 { $subsection watch }
+{ $subsection watch-vars }
+"Starting the walker when a word is called:"
 { $subsection breakpoint }
 { $subsection breakpoint-if }
+"Timing words:"
+{ $subsection reset-word-timing }
+{ $subsection add-timing }
+{ $subsection word-timing. }
 "All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:"
 { $subsection annotate } ;
 
@@ -63,3 +71,13 @@ HELP: word-inputs
      { "seq" sequence } }
 { $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ;
 
+HELP: add-timing
+{ $values { "word" word } }
+{ $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." }
+{ $see-also "tools.time" } ;
+
+HELP: reset-word-timing
+{ $description "Resets the word timing table." } ;
+
+HELP: word-timing.
+{ $description "Prints the word timing table." } ;
diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor
index 1e1eccb8b5..1e766e3dec 100644
--- a/basis/tools/annotations/annotations-tests.factor
+++ b/basis/tools/annotations/annotations-tests.factor
@@ -1,4 +1,4 @@
-USING: tools.test tools.annotations math parser eval
+USING: tools.test tools.annotations tools.time math parser eval
 io.streams.string kernel ;
 IN: tools.annotations.tests
 
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index 9847b16bc2..e5f6af2267 100644
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel words parser io summary quotations
-sequences prettyprint continuations effects definitions
-compiler.units namespaces assocs tools.walker generic
-inspector fry ;
+USING: accessors kernel math sorting words parser io summary
+quotations sequences prettyprint continuations effects
+definitions compiler.units namespaces assocs tools.walker
+tools.time generic inspector fry ;
 IN: tools.annotations
 
 GENERIC: reset ( word -- )
@@ -20,9 +20,11 @@ M: word reset
         f "unannotated-def" set-word-prop
     ] [ drop ] if ;
 
+ERROR: cannot-annotate-twice word ;
+
 : annotate ( word quot -- )
     over "unannotated-def" word-prop [
-        "Cannot annotate a word twice" throw
+        over cannot-annotate-twice
     ] when
     [
         over dup def>> "unannotated-def" set-word-prop
@@ -82,3 +84,21 @@ M: word annotate-methods
 
 : breakpoint-if ( word quot -- )
     '[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ;
+
+SYMBOL: word-timing
+
+H{ } clone word-timing set-global
+
+: reset-word-timing ( -- )
+    word-timing get clear-assoc ;
+
+: (add-timing) ( def word -- def' )
+    '[ _ benchmark _ word-timing get at+ ] ;
+
+: add-timing ( word -- )
+    dup '[ _ (add-timing) ] annotate ;
+
+: word-timing. ( -- )
+    word-timing get
+    >alist [ 1000000 /f ] assoc-map sort-values
+    simple-table. ;