extra/wordtimer/wordtimer.factor

   1 USING: accessors arrays assocs fry io kernel make math
   2 math.statistics namespaces prettyprint sequences sorting
   3 tools.annotations tools.time vocabs ;
   4 FROM: namespaces => change-global ;
   5 IN: wordtimer
   6
   7 SYMBOL: *wordtimes*
   8 SYMBOL: *calling*
   9
  10 : reset-word-timer ( -- )
  11     H{ } clone *wordtimes* set-global
  12     H{ } clone *calling* set-global ;
  13
  14 : lookup-word-time ( wordname -- utime n )
  15     *wordtimes* get-global [ drop { 0 0 } ] cache first2 ;
  16
  17 : update-times ( utime current-utime current-numinvokes -- utime' invokes' )
  18     rot [ + ] curry [ 1 + ] bi* ;
  19
  20 : register-time ( utime word -- )
  21     name>>
  22     [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ;
  23
  24 : calling ( word -- )
  25     dup *calling* get-global set-at ; inline
  26
  27 : finished ( word -- )
  28     *calling* get-global delete-at ; inline
  29
  30 : called-recursively? ( word -- t/f )
  31     *calling* get-global at ; inline
  32
  33 : timed-call ( quot word -- )
  34     [ calling ] [ [ benchmark ] dip register-time ] [ finished ] tri ; inline
  35
  36 : time-unless-recursing ( quot word -- )
  37     dup called-recursively? not
  38     [ timed-call ] [ drop call ] if ; inline
  39
  40 : (add-timer) ( word quot -- quot' )
  41     [ swap time-unless-recursing ] 2curry ;
  42
  43 : add-timer ( word -- )
  44     dup '[ [ _ ] dip (add-timer) ] annotate ;
  45
  46 : add-timers ( vocab -- )
  47     vocab-words [ add-timer ] each ;
  48
  49 : reset-vocab ( vocab -- )
  50     vocab-words [ reset ] each ;
  51
  52 : dummy-word ( -- ) ;
  53
  54 : time-dummy-word ( -- n )
  55     [ 100000 [ [ dummy-word ] benchmark , ] times ] { } make median ;
  56
  57 : subtract-overhead ( {oldtime,n} overhead -- {newtime,n} )
  58     [ first2 ] dip
  59     swap [ * - ] keep 2array ;
  60
  61 : (correct-for-timing-overhead) ( timingshash -- timingshash )
  62     time-dummy-word [ subtract-overhead ] curry assoc-map ;
  63
  64 : correct-for-timing-overhead ( -- )
  65     *wordtimes* [ (correct-for-timing-overhead) ] change-global ;
  66
  67 : print-word-timings ( -- )
  68     *wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ;
  69
  70 : wordtimer-call ( quot -- )
  71     reset-word-timer
  72     benchmark [
  73         correct-for-timing-overhead
  74         "total time:" write
  75     ] dip pprint nl
  76     print-word-timings nl ; inline
  77
  78 : profile-vocab ( vocab quot -- )
  79     "annotating vocab..." print flush
  80     over [ reset-vocab ] [ add-timers ] bi
  81     reset-word-timer
  82     "executing quotation..." print flush
  83     benchmark [
  84         "resetting annotations..." print flush
  85         reset-vocab
  86         correct-for-timing-overhead
  87         "total time:" write
  88     ] dip pprint
  89     print-word-timings ; inline