basis/timers/timers.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors calendar combinators.short-circuit fry kernel
   4 math math.functions quotations system threads typed ;
   5 IN: timers
   6
   7 TUPLE: timer
   8     { quot callable initial: [ ] }
   9     start-nanos
  10     delay-nanos
  11     interval-nanos
  12     iteration-start-nanos
  13     quotation-running?
  14     restart?
  15     thread ;
  16
  17 <PRIVATE
  18
  19 GENERIC: >nanoseconds ( obj -- duration/f )
  20 M: f >nanoseconds ;
  21 M: real >nanoseconds >integer ;
  22 M: duration >nanoseconds duration>nanoseconds >integer ;
  23
  24 TYPED: set-next-timer-time ( timer: timer -- timer )
  25     ! start + delay + ceiling((now - (start + delay)) / interval) * interval
  26     nano-count
  27     over start-nanos>> -
  28     over delay-nanos>> [ - ] when*
  29     over interval-nanos>> / ceiling
  30     over interval-nanos>> *
  31     over start-nanos>> +
  32     over delay-nanos>> [ + ] when*
  33     >>iteration-start-nanos ;
  34
  35 TYPED: stop-timer? ( timer: timer -- ? )
  36     { [ thread>> self eq? not ] [ restart?>> ] } 1|| ; inline
  37
  38 DEFER: call-timer-loop
  39
  40 TYPED: loop-timer ( timer: timer -- )
  41     nano-count over
  42     [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
  43     [ set-next-timer-time ] dip
  44     [ dup iteration-start-nanos>> ] [ 0 ] if
  45     0 or sleep-until call-timer-loop ;
  46
  47 TYPED: maybe-loop-timer ( timer: timer -- )
  48     dup { [ stop-timer? ] [ interval-nanos>> not ] } 1||
  49     [ drop ] [ loop-timer ] if ;
  50
  51 TYPED: call-timer-loop ( timer: timer -- )
  52     dup stop-timer? [
  53         drop
  54     ] [
  55         [
  56             [ t >>quotation-running? drop ]
  57             [ quot>> call( -- ) ]
  58             [ f >>quotation-running? drop ] tri
  59         ] keep
  60         maybe-loop-timer
  61     ] if ;
  62
  63 TYPED: sleep-delay ( timer: timer -- )
  64     dup stop-timer? [
  65         drop
  66     ] [
  67         nano-count >>start-nanos
  68         delay-nanos>> [ sleep ] when*
  69     ] if ;
  70
  71 TYPED: timer-loop ( timer: timer -- )
  72     [ sleep-delay ]
  73     [ nano-count >>iteration-start-nanos call-timer-loop ]
  74     [ dup restart?>> [ f >>restart? timer-loop ] [ drop ] if ] tri ;
  75
  76 PRIVATE>
  77
  78 : <timer> ( quot delay-duration/f interval-duration/f -- timer )
  79     timer new
  80         swap >nanoseconds >>interval-nanos
  81         swap >nanoseconds >>delay-nanos
  82         swap >>quot ; inline
  83
  84 : start-timer ( timer -- )
  85     [
  86         '[ _ timer-loop ] "Timer execution" spawn
  87     ] keep thread<< ;
  88
  89 : stop-timer ( timer -- )
  90     dup quotation-running?>> [
  91         f >>thread drop
  92     ] [
  93         [ [ interrupt ] when* f ] change-thread drop
  94     ] if ;
  95
  96 : restart-timer ( timer -- )
  97     t >>restart?
  98     dup quotation-running?>> [
  99         drop
 100     ] [
 101         dup thread>> [ nip interrupt ] [ start-timer ] if*
 102     ] if ;
 103
 104 <PRIVATE
 105
 106 : (start-timer) ( quot start-duration interval-duration -- timer )
 107     <timer> [ start-timer ] keep ; inline
 108
 109 PRIVATE>
 110
 111 : every ( quot interval-duration -- timer )
 112     [ f ] dip (start-timer) ;
 113
 114 : later ( quot delay-duration -- timer )
 115     f (start-timer) ;
 116
 117 : delayed-every ( quot duration -- timer )
 118     dup (start-timer) ;
 119
 120 : nanos-since ( nano-count -- nanos )
 121     [ nano-count ] dip - ;