extra/wordtimer/wordtimer.factor

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