From e3ddafbdecdd778e036bb7f0d99f80d2337e081c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Mar 2010 12:22:18 +1300
Subject: [PATCH] core-foundation.run-loop: clean up and speed up some code to
 fix starvation issue exposed by game.loop (reported by Joe Groff)

---
 .../core-foundation/run-loop/run-loop.factor  | 22 ++++++++-----------
 basis/core-foundation/time/time.factor        | 12 +++++-----
 basis/core-foundation/timers/timers.factor    |  4 ++--
 extra/game/loop/loop.factor                   |  2 +-
 4 files changed, 19 insertions(+), 21 deletions(-)

diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor
index 56b5a9c798..c1316eaa16 100644
--- a/basis/core-foundation/run-loop/run-loop.factor
+++ b/basis/core-foundation/run-loop/run-loop.factor
@@ -99,22 +99,18 @@ TUPLE: run-loop fds sources timers ;
 
 <PRIVATE
 
-: ((reset-timer)) ( timer counter timestamp -- )
-    nip >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
+: (reset-timer) ( timer timestamp -- )
+    >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
 
-: nano-count>timestamp ( x -- timestamp )
-    nano-count - nanoseconds now time+ ;
-
-: (reset-timer) ( timer counter -- )
-    yield {
-        { [ dup 0 = ] [ now ((reset-timer)) ] }
-        { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] }
-        { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
-        [ sleep-queue heap-peek nip nano-count>timestamp ((reset-timer)) ]
-    } cond ;
+: nano-count>micros ( x -- n )
+    nano-count - 1,000 /f system-micros + ;
 
 : reset-timer ( timer -- )
-    10 (reset-timer) ;
+    yield {
+        { [ run-queue deque-empty? not ] [ yield system-micros (reset-timer) ] }
+        { [ sleep-queue heap-empty? ] [ system-micros 1,000,000 + (reset-timer) ] }
+        [ sleep-queue heap-peek nip nano-count>micros (reset-timer) ]
+    } cond ;
 
 PRIVATE>
 
diff --git a/basis/core-foundation/time/time.factor b/basis/core-foundation/time/time.factor
index 8f09652462..59dd8098b4 100644
--- a/basis/core-foundation/time/time.factor
+++ b/basis/core-foundation/time/time.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: calendar alien.c-types alien.syntax ;
+USING: calendar math alien.c-types alien.syntax memoize system ;
 IN: core-foundation.time
 
 TYPEDEF: double CFTimeInterval
@@ -9,6 +9,8 @@ TYPEDEF: double CFAbsoluteTime
 : >CFTimeInterval ( duration -- interval )
     duration>seconds ; inline
 
-: >CFAbsoluteTime ( timestamp -- time )
-    T{ timestamp { year 2001 } { month 1 } { day 1 } } time-
-    duration>seconds ; inline
+MEMO: epoch ( -- micros )
+    T{ timestamp { year 2001 } { month 1 } { day 1 } } timestamp>micros ;
+
+: >CFAbsoluteTime ( micros -- time )
+    epoch - 1,000,000 /f ; inline
diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor
index cf17cb41d9..343753385a 100644
--- a/basis/core-foundation/timers/timers.factor
+++ b/basis/core-foundation/timers/timers.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.syntax system math kernel calendar
 core-foundation core-foundation.time ;
@@ -19,7 +19,7 @@ FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate (
 ) ;
 
 : <CFTimer> ( callback -- timer )
-    [ f now >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
+    [ f system-micros >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
 
 FUNCTION: void CFRunLoopTimerInvalidate (
    CFRunLoopTimerRef timer
diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor
index 9e46535b4e..00fe14c3cd 100644
--- a/extra/game/loop/loop.factor
+++ b/extra/game/loop/loop.factor
@@ -66,7 +66,7 @@ TUPLE: game-loop-error game-loop error ;
 
 : (run-loop) ( loop -- )
     dup running?>>
-    [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
+    [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
     [ drop ] if ;
 
 : run-loop ( loop -- )