timers: allow timers to re-use threads when restarted, simplify.

Throw an error if started twice.

basis/timers/timers-tests.factor

@@ -1,6 +1,6 @@
-USING: timers timers.private calendar concurrency.count-downs
+USING: accessors calendar combinators concurrency.count-downs
 concurrency.promises fry kernel math math.order sequences
-threads tools.test tools.time ;
+threads timers tools.test tools.time ;
 
 { } [
     1 <count-down>
@@ -74,3 +74,20 @@ threads tools.test tools.time ;
     dup restart-timer drop
     700 milliseconds sleep
 ] unit-test
+
+
+{ { 1 } t t t t } [
+    { 0 }
+    dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds f <timer>
+    dup start-timer [ thread>> ] keep {
+        [ dup restart-timer thread>> eq? ]
+        [ dup restart-timer thread>> eq? ]
+        [ dup restart-timer thread>> eq? ]
+        [ dup restart-timer thread>> eq? ]
+    } 2cleave
+    700 milliseconds sleep
+] unit-test
+
+[
+    [ ] 1 seconds later start-timer
+] [ timer-already-started? ] must-fail-with

basis/timers/timers.factor

@@ -1,17 +1,17 @@
 ! 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
@@ -21,60 +21,42 @@ M: f >nanoseconds ;
 M: real >nanoseconds >integer ;
 M: duration >nanoseconds duration>nanoseconds >integer ;
 
-TYPED: set-next-timer-time ( timer: timer -- timer )
+: delay-nanos ( timer -- n )
-    ! start + delay + ceiling((now - (start + delay)) / interval) * interval
+    delay-nanos>> 0 or nano-count + ;
-    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 -- ? )
+: interval-nanos ( timer -- n/f )
-    { [ thread>> self eq? not ] [ restart?>> ] } 1|| ; inline
+    [ next-nanos>> nano-count over - ] [ interval-nanos>> ] bi
+    [ dupd [ mod ] [ swap - ] bi + + ] [ 2drop f ] if* ;
 
-DEFER: call-timer-loop
+: 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 ;
 
-TYPED: loop-timer ( timer: timer -- )
+: run-timer ( timer -- timer )
-    nano-count over
+    dup interval-nanos >>next-nanos
-    [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
+    t >>quotation-running?
-    [ set-next-timer-time ] dip
+    dup quot>> call( -- )
-    [ dup iteration-start-nanos>> ] [ 0 ] if
+    f >>quotation-running? ;
-    0 or sleep-until call-timer-loop ;
 
-TYPED: maybe-loop-timer ( timer: timer -- )
+: timer-loop ( timer -- )
-    dup { [ stop-timer? ] [ interval-nanos>> not ] } 1||
+    [ next-nanos ] [
-    [ drop ] [ loop-timer ] if ;
+        dup nano-count <= [
+            drop run-timer yield
+        ] [
+            sleep-until
+        ] if
+    ] while* dup thread>> self eq? [ f >>thread ] when drop ;
 
-TYPED: call-timer-loop ( timer: timer -- )
+: ?interrupt ( thread timer -- )
-    dup stop-timer? [
+    quotation-running?>> [ drop ] [ [ interrupt ] when* ] if ;
-        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>
 
+ERROR: timer-already-started timer ;
+
 : <timer> ( quot delay-duration/f interval-duration/f -- timer )
     timer new
         swap >nanoseconds >>interval-nanos
@@ -82,20 +64,19 @@ PRIVATE>
         swap >>quot ; inline
 
 : start-timer ( timer -- )
-    [
+    dup thread>> [ timer-already-started ] when
-        '[ _ timer-loop ] "Timer execution" spawn
+    t >>next-nanos
-    ] keep thread<< ;
+    dup '[ _ timer-loop ] "Timer" <thread>
+    [ >>thread drop ] [ (spawn) ] bi ;
 
 : stop-timer ( timer -- )
-    dup quotation-running?>> [
+    [ f ] change-thread ?interrupt ;
-        dup thread>> [ interrupt ] when*
-    ] unless f >>thread drop ;
 
 : restart-timer ( timer -- )
-    dup quotation-running?>> [
+    dup thread>> [
-        t >>restart? drop
+        t >>next-nanos [ thread>> ] [ ?interrupt ] bi
     ] [
-        dup thread>> [ interrupt ] when* start-timer
+        start-timer
     ] if ;
 
 <PRIVATE
@@ -106,13 +87,10 @@ 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 - ;