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 fry kernel math quotations system
   5 threads ;
   6
   7 IN: timers
   8
   9 TUPLE: timer
  10     { quot callable initial: [ ] }
  11     delay-nanos
  12     interval-nanos
  13     next-nanos
  14     quotation-running?
  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 : delay-nanos ( timer -- n )
  25     delay-nanos>> 0 or nano-count + ;
  26
  27 : interval-nanos ( timer -- n/f )
  28     [ next-nanos>> nano-count over - ] [ interval-nanos>> ] bi
  29     [ dupd [ mod ] [ swap - ] bi + + ] [ 2drop f ] if* ;
  30
  31 : next-nanos ( timer -- timer n/f )
  32     dup thread>> self eq? [ dup next-nanos>> ] [ f ] if ;
  33
  34 : run-timer ( timer -- timer )
  35     dup interval-nanos >>next-nanos
  36     t >>quotation-running?
  37     dup quot>> call( -- )
  38     f >>quotation-running? ;
  39
  40 : timer-loop ( timer -- )
  41     [ next-nanos ] [
  42         dup nano-count <= [
  43             drop run-timer yield
  44         ] [
  45             sleep-until
  46         ] if
  47     ] while* dup thread>> self eq? [ f >>thread ] when drop ;
  48
  49 : ?interrupt ( thread timer -- )
  50     quotation-running?>> [ drop ] [ [ interrupt ] when* ] if ;
  51
  52 PRIVATE>
  53
  54 ERROR: timer-already-started timer ;
  55
  56 : <timer> ( quot delay-duration/f interval-duration/f -- timer )
  57     timer new
  58         swap >nanoseconds >>interval-nanos
  59         swap >nanoseconds >>delay-nanos
  60         swap >>quot ; inline
  61
  62 : start-timer ( timer -- )
  63     dup thread>> [ timer-already-started ] when
  64     dup delay-nanos >>next-nanos
  65     dup '[ _ timer-loop ] "Timer" <thread>
  66     [ >>thread drop ] [ (spawn) ] bi ;
  67
  68 : stop-timer ( timer -- )
  69     [ f ] change-thread ?interrupt ;
  70
  71 : restart-timer ( timer -- )
  72     dup thread>> [
  73         dup delay-nanos >>next-nanos
  74         [ thread>> ] [ ?interrupt ] bi
  75     ] [
  76         start-timer
  77     ] if ;
  78
  79 <PRIVATE
  80
  81 : (start-timer) ( quot start-duration interval-duration -- timer )
  82     <timer> [ start-timer ] keep ; inline
  83
  84 PRIVATE>
  85
  86 : every ( quot interval-duration -- timer )
  87     f swap (start-timer) ;
  88
  89 : later ( quot delay-duration -- timer )
  90     f (start-timer) ;
  91
  92 : delayed-every ( quot duration -- timer )
  93     dup (start-timer) ;