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