basis/timers/timers.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors calendar kernel math quotations system threads ;
   5
   6 IN: timers
   7
   8 TUPLE: timer
   9     { quot callable initial: [ ] }
  10     delay-nanos
  11     interval-nanos
  12     next-nanos
  13     quotation-running?
  14     thread ;
  15
  16 <PRIVATE
  17
  18 GENERIC: >nanoseconds ( obj -- duration/f )
  19 M: f >nanoseconds ;
  20 M: real >nanoseconds >integer ;
  21 M: duration >nanoseconds duration>nanoseconds >integer ;
  22
  23 : delay-nanos ( timer -- n )
  24     delay-nanos>> 0 or nano-count + ;
  25
  26 : interval-nanos ( timer -- n/f )
  27     [ next-nanos>> nano-count over - ] [ interval-nanos>> ] bi
  28     [ dupd [ mod ] [ swap - ] bi + + ] [ 2drop f ] if* ;
  29
  30 : next-nanos ( timer -- timer n/f )
  31     dup thread>> self eq? [ dup next-nanos>> ] [ f ] if ;
  32
  33 : run-timer ( timer -- timer )
  34     dup interval-nanos >>next-nanos
  35     t >>quotation-running?
  36     dup quot>> call( -- )
  37     f >>quotation-running? ;
  38
  39 : timer-loop ( timer -- )
  40     [ next-nanos ] [
  41         dup nano-count <= [
  42             drop run-timer yield
  43         ] [
  44             sleep-until
  45         ] if
  46     ] while* dup thread>> self eq? [ f >>thread ] when drop ;
  47
  48 : ?interrupt ( thread timer -- )
  49     quotation-running?>> [ drop ] [ [ interrupt ] when* ] if ;
  50
  51 PRIVATE>
  52
  53 ERROR: timer-already-started timer ;
  54
  55 : <timer> ( quot delay-duration/f interval-duration/f -- timer )
  56     timer new
  57         swap >nanoseconds >>interval-nanos
  58         swap >nanoseconds >>delay-nanos
  59         swap >>quot ; inline
  60
  61 : start-timer ( timer -- )
  62     dup thread>> [ timer-already-started ] when
  63     dup delay-nanos >>next-nanos
  64     dup '[ _ timer-loop ] "Timer" <thread>
  65     [ >>thread drop ] [ (spawn) ] bi ;
  66
  67 : stop-timer ( timer -- )
  68     [ f ] change-thread ?interrupt ;
  69
  70 : restart-timer ( timer -- )
  71     dup thread>> [
  72         dup delay-nanos >>next-nanos
  73         [ thread>> ] [ ?interrupt ] bi
  74     ] [
  75         start-timer
  76     ] if ;
  77
  78 <PRIVATE
  79
  80 : (start-timer) ( quot start-duration interval-duration -- timer )
  81     <timer> [ start-timer ] keep ; inline
  82
  83 PRIVATE>
  84
  85 : every ( quot interval-duration -- timer )
  86     f swap (start-timer) ;
  87
  88 : later ( quot delay-duration -- timer )
  89     f (start-timer) ;
  90
  91 : delayed-every ( quot duration -- timer )
  92     dup (start-timer) ;