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