basis/tools/annotations/annotations.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators.short-circuit compiler.units effects
   4 generalizations generic inspector io kernel math namespaces prettyprint
   5 quotations sequences sequences.deep sequences.generalizations sorting summary
   6 tools.time vocabs words ;
   7 IN: tools.annotations
   8
   9 SYMBOL: override-annotations?
  10
  11 <PRIVATE
  12
  13 GENERIC: (reset) ( word -- )
  14
  15 M: generic (reset)
  16     subwords [ (reset) ] each ;
  17
  18 M: word (reset)
  19     dup "unannotated-def" word-prop [
  20         dupd define "unannotated-def" remove-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 PREDICATE: annotated < word "unannotated-def" word-prop >boolean ;
  33
  34 <PRIVATE
  35
  36 : check-annotate-twice ( word -- word )
  37     dup annotated?
  38     [ override-annotations? get
  39       [ dup reset ]
  40       [ cannot-annotate-twice ] if
  41     ] when ;
  42
  43 : annotate-generic ( word quot -- )
  44     [ "methods" word-prop values ] dip each ; inline
  45
  46 : prepare-annotate ( word quot -- word quot quot )
  47     [ check-annotate-twice ] dip
  48     [ dup def>> 2dup "unannotated-def" set-word-prop ] dip ;
  49
  50 GENERIC#: (annotate) 1 ( word quot -- )
  51
  52 M: generic (annotate)
  53     '[ _ (annotate) ] annotate-generic ;
  54
  55 M: word (annotate)
  56     prepare-annotate
  57     call( old -- new ) define ;
  58
  59 GENERIC#: (deep-annotate) 1 ( word quot -- )
  60
  61 M: generic (deep-annotate)
  62     '[ _ (deep-annotate) ] annotate-generic ;
  63
  64 M: word (deep-annotate)
  65     prepare-annotate
  66     '[ dup callable? [ _ call( old -- new ) ] when ] deep-map define ;
  67
  68 PRIVATE>
  69
  70 : annotate ( word quot -- )
  71     [ (annotate) ] with-compilation-unit ;
  72
  73 : deep-annotate ( word quot -- )
  74     [ (deep-annotate) ] with-compilation-unit ;
  75
  76 : reset-all ( -- )
  77     all-words [
  78         dup { [ annotated? ] [ subwords [ annotated? ] any? ] } 1||
  79         [ reset ] [ drop ] if
  80     ] each ;
  81
  82 <PRIVATE
  83
  84 :: trace-quot ( word effect quot str -- quot' )
  85     effect quot call :> values
  86     values length :> n
  87     [
  88         [
  89             "--- " write str write bl word .
  90             n ndup n narray values swap zip simple-table.
  91             flush
  92         ] with-output>error
  93     ] ; inline
  94
  95 MACRO: entering ( word -- quot )
  96     dup stack-effect [ in>> ] "Entering" trace-quot ;
  97
  98 MACRO: leaving ( word -- quot )
  99     dup stack-effect [ out>> ] "Leaving" trace-quot ;
 100
 101 : (watch) ( word def -- def )
 102     over '[ _ entering @ _ leaving ] ;
 103
 104 PRIVATE>
 105
 106 : watch ( word -- )
 107     dup '[ [ _ ] dip (watch) ] annotate ;
 108
 109 <PRIVATE
 110
 111 : (watch-vars) ( word vars quot -- newquot )
 112    '[
 113         [
 114             "--- Entering: " write _ .
 115             "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
 116             @
 117         ] with-output>error
 118     ] ;
 119
 120 PRIVATE>
 121
 122 : watch-vars ( word vars -- )
 123     dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
 124
 125 SYMBOL: word-timing
 126
 127 word-timing [ H{ } clone ] initialize
 128
 129 : reset-word-timing ( -- )
 130     word-timing get clear-assoc ;
 131
 132 <PRIVATE
 133
 134 : (add-timing) ( def word -- def' )
 135     '[
 136         _ benchmark _ word-timing get [
 137             [
 138                 [ 0 swap [ + ] change-nth ] keep
 139                 [ 1 swap [ 1 + ] change-nth ] keep
 140             ] [ 1 2array ] if*
 141         ] change-at
 142     ] ;
 143
 144 PRIVATE>
 145
 146 : add-timing ( word -- )
 147     dup '[ _ (add-timing) ] annotate ;
 148
 149 : word-timing. ( -- )
 150     word-timing get >alist
 151     [ second first ] sort-with
 152     [ first2 first2 [ 1,000,000,000 /f ] dip 3array ] map
 153     simple-table. ;