basis/tools/annotations/annotations.factor

   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 ;
   7 IN: tools.annotations
   8
   9 <PRIVATE
  10
  11 GENERIC: (reset) ( word -- )
  12
  13 M: generic (reset)
  14     subwords [ (reset) ] each ;
  15
  16 M: word (reset)
  17     dup "unannotated-def" word-prop [
  18         dup dup "unannotated-def" word-prop define
  19         f "unannotated-def" set-word-prop
  20     ] [ drop ] if ;
  21
  22 PRIVATE>
  23
  24 : reset ( word -- )
  25     [ (reset) ] with-compilation-unit ;
  26
  27 ERROR: cannot-annotate-twice word ;
  28
  29 M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
  30
  31 PREDICATE: annotated < word "unannotated-def" word-prop >boolean ;
  32
  33 <PRIVATE
  34
  35 : check-annotate-twice ( word -- word )
  36     dup annotated? [ cannot-annotate-twice ] when ;
  37
  38 : annotate-generic ( word quot -- )
  39     [ "methods" word-prop values ] dip each ; inline
  40
  41 : prepare-annotate ( word quot -- word quot quot )
  42     [ check-annotate-twice ] dip
  43     [ dup def>> 2dup "unannotated-def" set-word-prop ] dip ;
  44
  45 GENERIC# (annotate) 1 ( word quot -- )
  46
  47 M: generic (annotate)
  48     '[ _ (annotate) ] annotate-generic ;
  49
  50 M: word (annotate)
  51     prepare-annotate
  52     call( old -- new ) define ;
  53
  54 GENERIC# (deep-annotate) 1 ( word quot -- )
  55
  56 M: generic (deep-annotate)
  57     '[ _ (deep-annotate) ] annotate-generic ;
  58
  59 M: word (deep-annotate)
  60     prepare-annotate
  61     '[ dup callable? [ _ call( old -- new ) ] when ] deep-map define ;
  62
  63 PRIVATE>
  64
  65 : annotate ( word quot -- )
  66     [ (annotate) ] with-compilation-unit ;
  67
  68 : deep-annotate ( word quot -- )
  69     [ (deep-annotate) ] with-compilation-unit ;
  70
  71 <PRIVATE
  72
  73 :: trace-quot ( word effect quot str -- quot' )
  74     effect quot call :> values
  75     values length :> n
  76     [
  77         [
  78             "--- " write str write bl word .
  79             n ndup n narray values swap zip simple-table.
  80             flush
  81         ] with-output>error
  82     ] ; inline
  83
  84 MACRO: entering ( word -- quot )
  85     dup stack-effect [ in>> ] "Entering" trace-quot ;
  86
  87 MACRO: leaving ( word -- quot )
  88     dup stack-effect [ out>> ] "Leaving" trace-quot ;
  89
  90 : (watch) ( word def -- def )
  91     over '[ _ entering @ _ leaving ] ;
  92
  93 PRIVATE>
  94
  95 : watch ( word -- )
  96     dup '[ [ _ ] dip (watch) ] annotate ;
  97
  98 <PRIVATE
  99
 100 : (watch-vars) ( word vars quot -- newquot )
 101    '[
 102         [
 103             "--- Entering: " write _ .
 104             "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
 105             @
 106         ] with-output>error
 107     ] ;
 108
 109 PRIVATE>
 110
 111 : watch-vars ( word vars -- )
 112     dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
 113
 114 SYMBOL: word-timing
 115
 116 word-timing [ H{ } clone ] initialize
 117
 118 : reset-word-timing ( -- )
 119     word-timing get clear-assoc ;
 120
 121 <PRIVATE
 122
 123 : (add-timing) ( def word -- def' )
 124     '[
 125         _ benchmark _ word-timing get [
 126             [
 127                 [ 0 swap [ + ] change-nth ] keep
 128                 [ 1 swap [ 1 + ] change-nth ] keep
 129             ] [ 1 2array ] if*
 130         ] change-at
 131     ] ;
 132
 133 PRIVATE>
 134
 135 : add-timing ( word -- )
 136     dup '[ _ (add-timing) ] annotate ;
 137
 138 : word-timing. ( -- )
 139     word-timing get >alist
 140     [ second first ] sort-with
 141     [ first2 first2 [ 1,000,000,000 /f ] dip 3array ] map
 142     simple-table. ;