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.walker
   6 tools.time generic inspector fry tools.continuations
   7 locals generalizations macros ;
   8 IN: tools.annotations
   9
  10 <PRIVATE
  11
  12 GENERIC: (reset) ( word -- )
  13
  14 M: generic (reset)
  15     subwords [ (reset) ] each ;
  16
  17 M: word (reset)
  18     dup "unannotated-def" word-prop [
  19         dup dup "unannotated-def" word-prop define
  20         f "unannotated-def" set-word-prop
  21     ] [ drop ] if ;
  22
  23 PRIVATE>
  24
  25 : reset ( word -- )
  26     [ (reset) ] with-compilation-unit ;
  27
  28 ERROR: cannot-annotate-twice word ;
  29
  30 M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
  31
  32 <PRIVATE
  33
  34 : check-annotate-twice ( word -- word )
  35     dup "unannotated-def" word-prop [
  36         cannot-annotate-twice
  37     ] when ;
  38
  39 GENERIC# (annotate) 1 ( word quot -- )
  40
  41 M: generic (annotate)
  42     [ "methods" word-prop values ] dip '[ _ (annotate) ] each ;
  43
  44 M: word (annotate)
  45     [ check-annotate-twice ] dip
  46     [ dup def>> 2dup "unannotated-def" set-word-prop ] dip
  47     call( old -- new ) define ;
  48
  49 PRIVATE>
  50
  51 : annotate ( word quot -- )
  52     [ (annotate) ] with-compilation-unit ;
  53
  54 <PRIVATE
  55
  56 :: trace-quot ( word effect quot str -- quot' )
  57     effect quot call :> values
  58     values length :> n
  59     [
  60         "--- " write str write bl word .
  61         n ndup n narray values swap zip simple-table.
  62         flush
  63     ] ; inline
  64
  65 MACRO: entering ( word -- quot )
  66     dup stack-effect [ in>> ] "Entering" trace-quot ;
  67
  68 MACRO: leaving ( word -- quot )
  69     dup stack-effect [ out>> ] "Leaving" trace-quot ;
  70
  71 : (watch) ( word def -- def )
  72     over '[ _ entering @ _ leaving ] ;
  73
  74 PRIVATE>
  75
  76 : watch ( word -- )
  77     dup '[ [ _ ] dip (watch) ] annotate ;
  78
  79 <PRIVATE
  80
  81 : (watch-vars) ( word vars quot -- newquot )
  82    '[
  83         "--- Entering: " write _ .
  84         "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
  85         @
  86     ] ;
  87
  88 PRIVATE>
  89
  90 : watch-vars ( word vars -- )
  91     dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
  92
  93 : breakpoint ( word -- )
  94     [ add-breakpoint ] annotate ;
  95
  96 : breakpoint-if ( word quot -- )
  97     '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ;
  98
  99 SYMBOL: word-timing
 100
 101 word-timing [ H{ } clone ] initialize
 102
 103 : reset-word-timing ( -- )
 104     word-timing get clear-assoc ;
 105
 106 <PRIVATE
 107
 108 : (add-timing) ( def word -- def' )
 109     '[ _ benchmark _ word-timing get at+ ] ;
 110
 111 PRIVATE>
 112
 113 : add-timing ( word -- )
 114     dup '[ _ (add-timing) ] annotate ;
 115
 116 : word-timing. ( -- )
 117     word-timing get
 118     >alist [ 1000000 /f ] assoc-map sort-values
 119     simple-table. ;