basis/tools/annotations/annotations.factor

   1 ! Copyright (C) 2005, 2008 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 ;
   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 : annotate ( word quot -- )
  26     over "unannotated-def" word-prop [
  27         over cannot-annotate-twice
  28     ] when
  29     [
  30         over dup def>> "unannotated-def" set-word-prop
  31         [ dup def>> ] dip call define
  32     ] with-compilation-unit ; inline
  33
  34 : word-inputs ( word -- seq )
  35     stack-effect [
  36         [ datastack ] dip in>> length tail*
  37     ] [
  38         datastack
  39     ] if* ;
  40
  41 : entering ( str -- )
  42     "/-- Entering: " write dup .
  43     word-inputs stack.
  44     "\\--" print flush ;
  45
  46 : word-outputs ( word -- seq )
  47     stack-effect [
  48         [ datastack ] dip out>> length tail*
  49     ] [
  50         datastack
  51     ] if* ;
  52
  53 : leaving ( str -- )
  54     "/-- Leaving: " write dup .
  55     word-outputs stack.
  56      "\\--" print flush ;
  57
  58 : (watch) ( word def -- def )
  59     over '[ _ entering @ _ leaving ] ;
  60
  61 : watch ( word -- )
  62     dup [ (watch) ] annotate ;
  63
  64 : (watch-vars) ( word vars quot -- newquot )
  65    '[
  66         "--- Entering: " write _ .
  67         "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
  68         @
  69     ] ;
  70
  71 : watch-vars ( word vars -- )
  72     dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
  73
  74 GENERIC# annotate-methods 1 ( word quot -- )
  75
  76 M: generic annotate-methods
  77     [ "methods" word-prop values ] dip [ annotate ] curry each ;
  78
  79 M: word annotate-methods
  80     annotate ;
  81
  82 : breakpoint ( word -- )
  83     [ add-breakpoint ] annotate-methods ;
  84
  85 : breakpoint-if ( word quot -- )
  86     '[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ;
  87
  88 SYMBOL: word-timing
  89
  90 word-timing global [ H{ } clone or ] change-at
  91
  92 : reset-word-timing ( -- )
  93     word-timing get clear-assoc ;
  94
  95 : (add-timing) ( def word -- def' )
  96     '[ _ benchmark _ word-timing get at+ ] ;
  97
  98 : add-timing ( word -- )
  99     dup '[ _ (add-timing) ] annotate ;
 100
 101 : word-timing. ( -- )
 102     word-timing get
 103     >alist [ 1000000 /f ] assoc-map sort-values
 104     simple-table. ;