extra/wordtimer/wordtimer.factor

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