factor/basis/timers/timers.factor

122 lines
3.0 KiB
Factor

! 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 ;
IN: timers
TUPLE: timer
{ quot callable initial: [ ] }
start-nanos
delay-nanos
interval-nanos
iteration-start-nanos
quotation-running?
restart?
thread ;
<PRIVATE
GENERIC: >nanoseconds ( obj -- duration/f )
M: f >nanoseconds ;
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 ;
PRIVATE>
: <timer> ( quot delay-duration/f interval-duration/f -- timer )
timer new
swap >nanoseconds >>interval-nanos
swap >nanoseconds >>delay-nanos
swap >>quot ; inline
: start-timer ( timer -- )
[
'[ _ timer-loop ] "Timer execution" spawn
] keep thread<< ;
: stop-timer ( timer -- )
dup quotation-running?>> [
f >>thread drop
] [
[ [ interrupt ] when* f ] change-thread drop
] if ;
: restart-timer ( timer -- )
t >>restart?
dup quotation-running?>> [
drop
] [
dup thread>> [ nip interrupt ] [ start-timer ] if*
] if ;
<PRIVATE
: (start-timer) ( quot start-duration interval-duration -- timer )
<timer> [ start-timer ] keep ; inline
PRIVATE>
: every ( quot interval-duration -- timer )
[ f ] dip (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 - ;