1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs compiler.units effects fry
4 generalizations generic inspector io kernel locals macros math
5 namespaces prettyprint quotations sequences sequences.deep
6 sequences.generalizations sorting summary tools.time words ;
11 GENERIC: (reset) ( word -- )
14 subwords [ (reset) ] each ;
17 dup "unannotated-def" word-prop [
18 dup dup "unannotated-def" word-prop define
19 f "unannotated-def" set-word-prop
25 [ (reset) ] with-compilation-unit ;
27 ERROR: cannot-annotate-twice word ;
29 M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
31 PREDICATE: annotated < word "unannotated-def" word-prop >boolean ;
35 : check-annotate-twice ( word -- word )
36 dup annotated? [ throw-cannot-annotate-twice ] when ;
38 : annotate-generic ( word quot -- )
39 [ "methods" word-prop values ] dip each ; inline
41 : prepare-annotate ( word quot -- word quot quot )
42 [ check-annotate-twice ] dip
43 [ dup def>> 2dup "unannotated-def" set-word-prop ] dip ;
45 GENERIC# (annotate) 1 ( word quot -- )
48 '[ _ (annotate) ] annotate-generic ;
52 call( old -- new ) define ;
54 GENERIC# (deep-annotate) 1 ( word quot -- )
56 M: generic (deep-annotate)
57 '[ _ (deep-annotate) ] annotate-generic ;
59 M: word (deep-annotate)
61 '[ dup callable? [ _ call( old -- new ) ] when ] deep-map define ;
65 : annotate ( word quot -- )
66 [ (annotate) ] with-compilation-unit ;
68 : deep-annotate ( word quot -- )
69 [ (deep-annotate) ] with-compilation-unit ;
73 :: trace-quot ( word effect quot str -- quot' )
74 effect quot call :> values
78 "--- " write str write bl word .
79 n ndup n narray values swap zip simple-table.
84 MACRO: entering ( word -- quot )
85 dup stack-effect [ in>> ] "Entering" trace-quot ;
87 MACRO: leaving ( word -- quot )
88 dup stack-effect [ out>> ] "Leaving" trace-quot ;
90 : (watch) ( word def -- def )
91 over '[ _ entering @ _ leaving ] ;
96 dup '[ [ _ ] dip (watch) ] annotate ;
100 : (watch-vars) ( word vars quot -- newquot )
103 "--- Entering: " write _ .
104 "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
111 : watch-vars ( word vars -- )
112 dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
116 word-timing [ H{ } clone ] initialize
118 : reset-word-timing ( -- )
119 word-timing get clear-assoc ;
123 : (add-timing) ( def word -- def' )
125 _ benchmark _ word-timing get [
127 [ 0 swap [ + ] change-nth ] keep
128 [ 1 swap [ 1 + ] change-nth ] keep
135 : add-timing ( word -- )
136 dup '[ _ (add-timing) ] annotate ;
138 : word-timing. ( -- )
139 word-timing get >alist
140 [ second first ] sort-with
141 [ first2 first2 [ 1,000,000,000 /f ] dip 3array ] map