basis/tools/annotations/annotations.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel math sorting words parser io summary
   4 quotations sequences prettyprint continuations effects
   5 definitions compiler.units namespaces assocs tools.time generic
   6 inspector fry locals generalizations macros ;
   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 <PRIVATE
  32
  33 : check-annotate-twice ( word -- word )
  34     dup "unannotated-def" word-prop [
  35         cannot-annotate-twice
  36     ] when ;
  37
  38 GENERIC# (annotate) 1 ( word quot -- )
  39
  40 M: generic (annotate)
  41     [ "methods" word-prop values ] dip '[ _ (annotate) ] each ;
  42
  43 M: word (annotate)
  44     [ check-annotate-twice ] dip
  45     [ dup def>> 2dup "unannotated-def" set-word-prop ] dip
  46     call( old -- new ) define ;
  47
  48 PRIVATE>
  49
  50 : annotate ( word quot -- )
  51     [ (annotate) ] with-compilation-unit ;
  52
  53 <PRIVATE
  54
  55 :: trace-quot ( word effect quot str -- quot' )
  56     effect quot call :> values
  57     values length :> n
  58     [
  59         "--- " write str write bl word .
  60         n ndup n narray values swap zip simple-table.
  61         flush
  62     ] ; inline
  63
  64 MACRO: entering ( word -- quot )
  65     dup stack-effect [ in>> ] "Entering" trace-quot ;
  66
  67 MACRO: leaving ( word -- quot )
  68     dup stack-effect [ out>> ] "Leaving" trace-quot ;
  69
  70 : (watch) ( word def -- def )
  71     over '[ _ entering @ _ leaving ] ;
  72
  73 PRIVATE>
  74
  75 : watch ( word -- )
  76     dup '[ [ _ ] dip (watch) ] annotate ;
  77
  78 <PRIVATE
  79
  80 : (watch-vars) ( word vars quot -- newquot )
  81    '[
  82         "--- Entering: " write _ .
  83         "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
  84         @
  85     ] ;
  86
  87 PRIVATE>
  88
  89 : watch-vars ( word vars -- )
  90     dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
  91
  92 SYMBOL: word-timing
  93
  94 word-timing [ H{ } clone ] initialize
  95
  96 : reset-word-timing ( -- )
  97     word-timing get clear-assoc ;
  98
  99 <PRIVATE
 100
 101 : (add-timing) ( def word -- def' )
 102     '[ _ benchmark _ word-timing get at+ ] ;
 103
 104 PRIVATE>
 105
 106 : add-timing ( word -- )
 107     dup '[ _ (add-timing) ] annotate ;
 108
 109 : word-timing. ( -- )
 110     word-timing get
 111     >alist [ 1000000 /f ] assoc-map sort-values
 112     simple-table. ;