! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors calendar combinators.short-circuit fry kernel
-math math.functions quotations system threads typed ;
+
+USING: accessors calendar fry kernel math quotations system
+threads ;
+
IN: timers
TUPLE: timer
{ quot callable initial: [ ] }
- start-nanos
delay-nanos
interval-nanos
- iteration-start-nanos
+ next-nanos
quotation-running?
- restart?
thread ;
<PRIVATE
M: real >nanoseconds >integer ;
M: duration >nanoseconds duration>nanoseconds >integer ;
-TYPED: set-next-timer-time ( timer: timer -- timer )
- ! start + delay + ceiling((now - (start + delay)) / interval) * interval
- nano-count
- over start-nanos>> -
- over delay-nanos>> [ - ] when*
- over interval-nanos>> / ceiling
- over interval-nanos>> *
- over start-nanos>> +
- over delay-nanos>> [ + ] when*
- >>iteration-start-nanos ;
-
-TYPED: stop-timer? ( timer: timer -- ? )
- { [ thread>> self eq? not ] [ restart?>> ] } 1|| ; inline
-
-DEFER: call-timer-loop
-
-TYPED: loop-timer ( timer: timer -- )
- nano-count over
- [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
- [ set-next-timer-time ] dip
- [ dup iteration-start-nanos>> ] [ 0 ] if
- 0 or sleep-until call-timer-loop ;
-
-TYPED: maybe-loop-timer ( timer: timer -- )
- dup { [ stop-timer? ] [ interval-nanos>> not ] } 1||
- [ drop ] [ loop-timer ] if ;
-
-TYPED: call-timer-loop ( timer: timer -- )
- dup stop-timer? [
- drop
- ] [
- [
- [ t >>quotation-running? drop ]
- [ quot>> call( -- ) ]
- [ f >>quotation-running? drop ] tri
- ] keep
- maybe-loop-timer
- ] if ;
-
-TYPED: sleep-delay ( timer: timer -- )
- dup stop-timer? [
- drop
- ] [
- nano-count >>start-nanos
- delay-nanos>> [ sleep ] when*
- ] if ;
-
-TYPED: timer-loop ( timer: timer -- )
- [ sleep-delay ]
- [ nano-count >>iteration-start-nanos call-timer-loop ]
- [ dup restart?>> [ f >>restart? timer-loop ] [ drop ] if ] tri ;
+: delay-nanos ( timer -- n )
+ delay-nanos>> 0 or nano-count + ;
+
+: interval-nanos ( timer -- n/f )
+ [ next-nanos>> nano-count over - ] [ interval-nanos>> ] bi
+ [ dupd [ mod ] [ swap - ] bi + + ] [ 2drop f ] if* ;
+
+: next-nanos ( timer -- timer n/f )
+ dup thread>> self eq? [
+ dup next-nanos>> dup t eq? [
+ drop dup delay-nanos [ >>next-nanos ] keep
+ ] when
+ ] [ f ] if ;
+
+: run-timer ( timer -- timer )
+ dup interval-nanos >>next-nanos
+ t >>quotation-running?
+ dup quot>> call( -- )
+ f >>quotation-running? ;
+
+: timer-loop ( timer -- )
+ [ next-nanos ] [
+ dup nano-count <= [
+ drop run-timer yield
+ ] [
+ sleep-until
+ ] if
+ ] while* dup thread>> self eq? [ f >>thread ] when drop ;
+
+: ?interrupt ( thread timer -- )
+ quotation-running?>> [ drop ] [ [ interrupt ] when* ] if ;
PRIVATE>
+ERROR: timer-already-started timer ;
+
: <timer> ( quot delay-duration/f interval-duration/f -- timer )
timer new
swap >nanoseconds >>interval-nanos
swap >>quot ; inline
: start-timer ( timer -- )
- [
- '[ _ timer-loop ] "Timer execution" spawn
- ] keep thread<< ;
+ dup thread>> [ timer-already-started ] when
+ t >>next-nanos
+ dup '[ _ timer-loop ] "Timer" <thread>
+ [ >>thread drop ] [ (spawn) ] bi ;
: stop-timer ( timer -- )
- dup quotation-running?>> [
- dup thread>> [ interrupt ] when*
- ] unless f >>thread drop ;
+ [ f ] change-thread ?interrupt ;
: restart-timer ( timer -- )
- dup quotation-running?>> [
- t >>restart? drop
+ dup thread>> [
+ t >>next-nanos [ thread>> ] [ ?interrupt ] bi
] [
- dup thread>> [ interrupt ] when* start-timer
+ start-timer
] if ;
<PRIVATE
PRIVATE>
: every ( quot interval-duration -- timer )
- [ f ] dip (start-timer) ;
+ f swap (start-timer) ;
: later ( quot delay-duration -- timer )
f (start-timer) ;
: delayed-every ( quot duration -- timer )
dup (start-timer) ;
-
-: nanos-since ( nano-count -- nanos )
- [ nano-count ] dip - ;