Threading/IO updates

diff --git a/library/bootstrap/init.factor b/library/bootstrap/init.factor
index c9df1757816f2d9640ccdd51838db73013ee7f7d..bc0854d8aa8a562847a4614a230d514a8da68b5a 100644 (file)
--- a/library/bootstrap/init.factor
+++ b/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 ;

diff --git a/library/io/win32-io-internals.factor b/library/io/win32-io-internals.factor
index 2796a6506f35de04bf98e65b3edc25aeda3a7de2..2f25cc2a50c1c2c8f2fe681c1f39d234a614dc9d 100644 (file)
--- a/library/io/win32-io-internals.factor
+++ b/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 ;
 

diff --git a/library/lists.factor b/library/lists.factor
index f1cea1f2552d927ff271121df595fab000f047e4..00591dcd2204e36aa012654d2ec82f7f95a42ecf 100644 (file)
--- a/library/lists.factor
+++ b/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 ;
+

diff --git a/library/threads.factor b/library/threads.factor
index 70089b39da3c4711cdbbd65487883ff8c5c3eeac..30f719c8d6ab49269b9e894064d4986bf3e91bcc 100644 (file)
--- a/library/threads.factor
+++ b/library/threads.factor
@@ -2,20 +2,21 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: threads
 USING: io-internals kernel kernel-internals lists namespaces ;
-
+ 
 ! Core of the multitasker. Used by io-internals.factor and
 ! in-thread.factor.
 
 : 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 ;
+

diff --git a/library/ui/console.factor b/library/ui/console.factor
index e27a85a356e728d69d16ba265f13ef716bfa5259..50828c8299c1cd5a65a4103eaea3956fab70d1b1 100644 (file)
--- a/library/ui/console.factor
+++ b/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*

diff --git a/library/win32/win32-errors.factor b/library/win32/win32-errors.factor
index ae237be8eea8d325af0f88d35c8ac1d7ace7f6fe..bdeabdb0a0696edbf9d905da9d87474e3ee32af8 100644 (file)
--- a/library/win32/win32-errors.factor
+++ b/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 ;