Threading/IO updates

library/bootstrap/init.factor

@@ -36,6 +36,7 @@ USE: words
 : boot ( -- )
     #! Initialize an interpreter with the basic services.
     init-namespaces
+    init-threads
     init-stdio
     "HOME" os-env [ "." ] unless* "~" set
     init-search-path ;

library/io/win32-io-internals.factor

@@ -26,16 +26,8 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: win32-io-internals
-USE: alien
-USE: errors
-USE: kernel
-USE: kernel-internals
-USE: lists
-USE: math
-USE: namespaces
-USE: prettyprint
-USE: vectors
-USE: win32-api
+USING: alien errors kernel kernel-internals lists math namespaces threads 
+       vectors win32-api ;
 
 SYMBOL: completion-port
 SYMBOL: io-queue
@@ -45,20 +37,11 @@ SYMBOL: callbacks
 : handle-io-error ( -- )
     #! If a write or read call fails unexpectedly, throw an error.
     GetLastError [ 
-        ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS 
+        ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS WAIT_TIMEOUT 
     ] contains? [ 
         win32-throw-error 
     ] unless ;
 
-: win32-init-stdio ( -- )
-    INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort
-    completion-port set 
-    
-    <namespace> [
-        32 <vector> callbacks set
-        f free-list set
-    ] extend io-queue set ;
-
 : add-completion ( handle -- )
     completion-port get NULL 1 CreateIoCompletionPort drop ;
 
@@ -125,10 +108,43 @@ END-STRUCT
         callbacks get vector-nth cdr
     ] bind ;
 
-: win32-next-io-task ( -- quot )
-    completion-port get <indirect-pointer> dup >r <indirect-pointer> 
-    <indirect-pointer> dup >r INFINITE GetQueuedCompletionStatus
-    [ handle-io-error ] unless
-    r> r> indirect-pointer-value swap indirect-pointer-value <alien> 
-    overlapped-ext-user-data get-io-callback call ;
+: (wait-for-io) ( timeout -- ? overlapped len )
+    >r completion-port get 
+    <indirect-pointer> [ 0 swap set-indirect-pointer-value ] keep 
+    <indirect-pointer> 
+    <indirect-pointer>
+    pick over r> -rot >r >r GetQueuedCompletionStatus r> r> ;
+
+: overlapped>callback ( overlapped -- callback )
+    indirect-pointer-value dup 0 = [
+        drop f
+    ] [
+        <alien> overlapped-ext-user-data get-io-callback
+    ] ifte ;
+
+: wait-for-io ( timeout -- callback len )
+    (wait-for-io) rot [ handle-io-error ] unless
+    overlapped>callback swap indirect-pointer-value ;
+
+: win32-next-io-task ( -- )
+    INFINITE wait-for-io swap call ;
+
+: win32-io-thread ( -- )
+    10 wait-for-io swap [
+        [ schedule-thread call ] callcc0
+    ] [
+        drop yield
+    ] ifte* 
+    win32-io-thread ;
+
+: win32-init-stdio ( -- )
+    INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort
+    completion-port set 
+    
+    <namespace> [
+        32 <vector> callbacks set
+        f free-list set
+    ] extend io-queue set 
+    
+    [ win32-io-thread ] in-thread ;
 

library/lists.factor

@@ -166,3 +166,30 @@ M: cons hashcode ( cons -- hash ) car hashcode ;
     #! Make a list of elements that occur in list2 but not
     #! list1.
     [ over contains? not ] subset nip ;
+
+TUPLE: dlist first last ;
+TUPLE: dlist-node next prev data ;
+
+C: dlist ;
+C: dlist-node
+    [ set-dlist-node-next ] keep
+    [ set-dlist-node-prev ] keep
+    [ set-dlist-node-data ] keep ;
+
+: dlist-push-end ( data dlist -- )
+    [ dlist-last f <dlist-node> ] keep
+    [ dlist-last [ dupd set-dlist-node-next ] when* ] keep
+    2dup set-dlist-last
+    dup dlist-first [ 2drop ] [ set-dlist-first ] ifte ;
+
+: dlist-empty? ( dlist -- ? )
+    dlist-first f = ;
+
+: (dlist-pop-front) ( dlist -- data )
+    [ dlist-first dlist-node-data ] keep
+    [ dup dlist-first dlist-node-next swap set-dlist-first ] keep
+    dup dlist-first [ drop ] [ f swap set-dlist-last ] ifte ;
+
+: dlist-pop-front ( dlist -- data )
+    dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] ifte ;
+

library/threads.factor

@@ -9,13 +9,14 @@ USING: io-internals kernel kernel-internals lists namespaces ;
 : run-queue ( -- queue ) 9 getenv ;
 : set-run-queue ( queue -- ) 9 setenv ;
 
+: init-threads ( -- )
+    <dlist> set-run-queue ;
+
 : next-thread ( -- quot )
-    #! Get and remove the next quotation from the run queue.
-    run-queue dup [ uncons set-run-queue ] when ;
+    run-queue dlist-pop-front ;
 
 : schedule-thread ( quot -- )
-    #! Add a quotation to the run queue.
-    run-queue cons set-run-queue ;
+    run-queue dlist-push-end ;
 
 : (yield) ( -- )
     #! If there is a quotation in the run queue, call it,
@@ -37,3 +38,4 @@ USING: io-internals kernel kernel-internals lists namespaces ;
     #! eventually be restored by a future call to (yield) or
     #! yield.
     [ schedule-thread (yield) ] callcc0 ;
+

library/ui/console.factor

@@ -363,7 +363,7 @@ M: alien handle-event ( event -- ? )
 
 : console-loop ( -- )
     redraw-console get [ draw-console redraw-console off ] when
-    check-event [ console-loop ] when ;
+    yield check-event [ console-loop ] when ;
 
 : console-quit ( -- )
     input-continuation get [ f swap call ] when*

library/win32/win32-errors.factor

@@ -43,6 +43,7 @@ USE: words
 CONSTANT: ERROR_SUCCESS 0 ;
 CONSTANT: ERROR_HANDLE_EOF 38 ;
 CONSTANT: ERROR_IO_PENDING 997 ;
+CONSTANT: WAIT_TIMEOUT 258 ;
 
 : FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ;
 : FORMAT_MESSAGE_IGNORE_INSERTS  HEX: 00000200 ;