UI thread cleanup

core/threads/threads.factor

@@ -86,6 +86,13 @@ PRIVATE>
     f over set-thread-state
     check-registered 2array run-queue push-front ;
 
+: sleep-time ( -- ms/f )
+    {
+        { [ run-queue dlist-empty? not ] [ 0 ] }
+        { [ sleep-queue heap-empty? ] [ f ] }
+        { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
+    } cond ;
+
 <PRIVATE
 
 : schedule-sleep ( thread ms -- )
@@ -106,23 +113,27 @@ PRIVATE>
     [ ] while
     drop ;
 
-: next ( -- )
+: next ( -- * )
     expire-sleep-loop
-    run-queue pop-back
+    run-queue dup dlist-empty? [
+        ! We should never be in a state where the only threads
+        ! are sleeping; the I/O wait thread is always runnable.
+        ! However, if it dies, we handle this case
+        ! semi-gracefully.
+        !
+        ! And if sleep-time outputs f, there are no sleeping
+        ! threads either... so WTF.
+        drop sleep-time [ die 0 ] unless* (sleep) next
+    ] [
+        pop-back
         dup array? [ first2 ] [ f swap ] if dup set-self
         f over set-thread-state
         thread-continuation box>
-    continue-with ;
+        continue-with
+    ] if ;
 
 PRIVATE>
 
-: sleep-time ( -- ms/f )
-    {
-        { [ run-queue dlist-empty? not ] [ 0 ] }
-        { [ sleep-queue heap-empty? ] [ f ] }
-        { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
-    } cond ;
-
 : stop ( -- )
     self dup thread-exit-handler call
     unregister-thread next ;

extra/ogg/player/player.factor

@@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ;
     dup player-gadget [
         dup { player-td player-yuv } get-slots theora_decode_YUVout drop
         dup player-rgb over player-yuv yuv>rgb
-        dup player-gadget relayout yield
+        dup player-gadget relayout-1 yield
     ] when ;
 
 : num-audio-buffers-processed ( player -- player n )

extra/ui/cocoa/cocoa.factor

@@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
 : event-loop ( -- )
     event-loop? [
         [
-            [ NSApp do-events ui-step ui-wait ] ui-try
+            [ NSApp do-events ui-wait ] ui-try
         ] with-autorelease-pool event-loop
     ] when ;
 

extra/ui/cocoa/views/views.factor

@@ -298,7 +298,6 @@ CLASS: {
     [
         [
             2drop dup view-dim swap window set-gadget-dim
-            ui-step
         ] ui-try
     ]
 }

extra/ui/ui-docs.factor

@@ -167,7 +167,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop"
 { $subsection start-ui }
 "The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
 $nl
-"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout and sleeps for 10 milliseconds." ;
+"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
 
 ARTICLE: "ui-backend-windows" "UI backend window management"
 "The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"

extra/ui/ui.factor

@@ -130,14 +130,31 @@ SYMBOL: ui-hook
 : notify-queued ( -- )
     graft-queue [ notify ] dlist-slurp ;
 
-: ui-step ( -- )
+: update-ui ( -- )
     [ notify-queued layout-queued redraw-worlds ] assert-depth ;
 
 : ui-wait ( -- )
     10 sleep ;
 
+: ui-try ( quot -- ) [ ui-error ] recover ;
+
+: ui-running ( quot -- )
+    t \ ui-running set-global
+    [ f \ ui-running set-global ] [ ] cleanup ; inline
+
+: ui-thread-running? ( -- ? )
+    ui-thread get-global self eq? \ ui-running get-global and ;
+
+: update-ui-loop ( -- )
+    ui-thread-running?
+    [ [ update-ui ] ui-try f sleep-until update-ui-loop ] when ;
+
+: start-ui-thread ( -- )
+    [ self ui-thread set-global update-ui-loop ]
+    "UI update" spawn drop ;
+
 : open-world-window ( world -- )
-    dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
+    dup pref-dim over set-gadget-dim dup relayout graft ;
 
 : open-window ( gadget title -- )
     >r [ 1 track, ] { 0 1 } make-track r>
@@ -158,16 +175,12 @@ M: object close-window
     find-world [ ungraft ] when* ;
 
 : start-ui ( -- )
-    self ui-thread set-global
+    start-ui-thread
     restore-windows? [
         restore-windows
     ] [
         init-ui ui-hook get call
-    ] if ui-step ;
+    ] if update-ui ;
-
-: ui-running ( quot -- )
-    t \ ui-running set-global
-    [ f \ ui-running set-global ] [ ] cleanup ; inline
 
 : ui-running? ( -- ? )
     \ ui-running get-global ;
@@ -185,5 +198,3 @@ MAIN: ui
         f windows set-global
         ui-hook [ ui ] with-variable
     ] if ;
-
-: ui-try ( quot -- ) [ ui-error ] recover ;

extra/ui/windows/windows.factor

@@ -85,12 +85,12 @@ SYMBOL: mouse-captured
 : handle-wm-paint ( hWnd uMsg wParam lParam -- )
     #! wParam and lParam are unused
     #! only paint if width/height both > 0
-    3drop window draw-world ;
+    3drop window relayout-1 ;
 
 : handle-wm-size ( hWnd uMsg wParam lParam -- )
     2nip
     [ lo-word ] keep hi-word 2array
-    dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
+    dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
 
 : handle-wm-move ( hWnd uMsg wParam lParam -- )
     2nip
@@ -353,14 +353,12 @@ M: windows-ui-backend (close-window)
 : event-loop ( msg -- )
     {
         { [ windows get empty? ] [ drop ] }
-        { [ dup peek-message? ] [
+        { [ dup peek-message? ] [ ui-wait event-loop ] }
-            >r [ ui-step ui-wait ] ui-try
-            r> event-loop
-        ] }
         { [ dup MSG-message WM_QUIT = ] [ drop ] }
         { [ t ] [
             dup TranslateMessage drop
             dup DispatchMessage drop
+            yield
             event-loop
         ] }
     } cond ;

extra/ui/x11/x11.factor

@@ -178,7 +178,7 @@ M: world client-event
         next-event dup
         None XFilterEvent zero? [ drop wait-event ] unless
     ] [
-        ui-step ui-wait wait-event
+        ui-wait wait-event
     ] if ;
 
 : do-events ( -- )