Clean up non-blocking wait-for-process support, implement on Unix (untested)

extra/io/launcher/launcher.factor

@@ -1,12 +1,25 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io io.backend system kernel namespaces strings hashtables
-sequences assocs combinators vocabs.loader ;
+sequences assocs combinators vocabs.loader init threads
+continuations ;
 IN: io.launcher
 
+! Non-blocking process exit notification facility
+SYMBOL: processes
+
+[ H{ } clone processes set-global ] "io.launcher" add-init-hook
+
 TUPLE: process handle status ;
 
-: <process> ( handle -- process ) f process construct-boa ;
+HOOK: register-process io-backend ( process -- )
+
+M: object register-process drop ;
+
+: <process> ( handle -- process )
+    f process construct-boa
+    V{ } clone over processes get set-at
+    dup register-process ;
 
 M: process equal? 2drop f ;
 
@@ -54,11 +67,10 @@ M: assoc >descriptor ;
 
 HOOK: run-process* io-backend ( desc -- handle )
 
-HOOK: wait-for-process* io-backend ( process -- )
-
 : wait-for-process ( process -- status )
-    dup process-handle [ dup wait-for-process* ] when
-    process-status ;
+    dup process-handle [
+        dup [ processes get at push stop ] curry callcc0
+    ] when process-status ;
 
 : run-process ( obj -- process )
     >descriptor
@@ -81,3 +93,8 @@ TUPLE: process-stream process ;
     swap <process-stream>
     [ swap with-stream ] keep
     process-stream-process ; inline
+
+: notify-exit ( status process -- )
+    [ set-process-status ] keep
+    [ processes get delete-at* drop [ schedule-thread ] each ] keep
+    f swap set-process-handle ;

extra/io/unix/bsd/bsd.factor

@@ -23,7 +23,7 @@ M: bsd-io init-io ( -- )
     2dup mx get-global mx-reads set-at
     mx get-global mx-writes set-at ;
 
-M: bsd-io wait-for-process ( pid -- status )
-    [ kqueue-mx get-global add-pid-task stop ] curry callcc1 ;
+M: bsd-io register-process ( process -- )
+    process-handle kqueue-mx get-global add-pid-task ;
 
 T{ bsd-io } set-io-backend

extra/io/unix/kqueue/kqueue.factor

@@ -5,7 +5,7 @@ sequences assocs unix unix.kqueue unix.process math namespaces
 combinators threads vectors ;
 IN: io.unix.kqueue
 
-TUPLE: kqueue-mx events processes ;
+TUPLE: kqueue-mx events ;
 
 : max-events ( -- n )
     #! We read up to 256 events at a time. This is an arbitrary
@@ -15,7 +15,6 @@ TUPLE: kqueue-mx events processes ;
 : <kqueue-mx> ( -- mx )
     kqueue-mx construct-mx
     kqueue dup io-error over set-mx-fd
-    H{ } clone over set-kqueue-mx-processes
     max-events "kevent" <c-array> over set-kqueue-mx-events ;
 
 GENERIC: io-task-filter ( task -- n )
@@ -52,9 +51,8 @@ M: kqueue-mx unregister-io-task ( task mx -- )
     over mx-reads at handle-io-task ;
 
 : kevent-proc-task ( mx pid -- )
-    dup (wait-for-pid) spin kqueue-mx-processes delete-at* [
-        [ schedule-thread-with ] with each
-    ] [ 2drop ] if ;
+    dup (wait-for-pid) swap find-process
+    dup [ notify-exit ] [ 2drop ] if ;
 
 : handle-kevent ( mx kevent -- )
     dup kevent-ident swap kevent-filter {
@@ -76,11 +74,5 @@ M: kqueue-mx wait-for-events ( ms mx -- )
     EVFILT_PROC over set-kevent-filter
     NOTE_EXIT over set-kevent-fflags ;
 
-: add-pid-task ( continuation pid mx -- )
-    2dup kqueue-mx-processes at* [
-        2nip push
-    ] [
-        drop
-        over make-proc-kevent over register-kevent
-        >r >r 1vector r> r> kqueue-mx-processes set-at
-    ] if ;
+: add-pid-task ( pid mx -- )
+    swap make-proc-kevent swap register-kevent ;

extra/io/unix/launcher/launcher.factor

@@ -9,10 +9,6 @@ IN: io.unix.launcher
 ! Search unix first
 USE: unix
 
-HOOK: wait-for-process io-backend ( pid -- status )
-
-M: unix-io wait-for-process ( pid -- status ) wait-for-pid ;
-
 ! Our command line parser. Supported syntax:
 ! foo bar baz -- simple tokens
 ! foo\ bar -- escaping the space
@@ -46,7 +42,7 @@ MEMO: 'arguments' ( -- parser )
 : assoc>env ( assoc -- env )
     [ "=" swap 3append ] { } assoc>map ;
 
-: (spawn-process) ( -- )
+: spawn-process ( -- )
     [
         get-arguments
         pass-environment?
@@ -55,20 +51,9 @@ MEMO: 'arguments' ( -- parser )
         io-error
     ] [ error. :c flush ] recover 1 exit ;
 
-: spawn-process ( -- pid )
-    [ (spawn-process) ] [ ] with-fork ;
-
-: spawn-detached ( -- )
-    [ spawn-process 0 exit ] [ ] with-fork
-    wait-for-process drop ;
-
-M: unix-io run-process* ( desc -- )
+M: unix-io run-process* ( desc -- pid )
     [
-        +detached+ get [
-            spawn-detached
-        ] [
-            spawn-process wait-for-process drop
-        ] if
+        [ spawn-process ] [ ] with-fork <process>
     ] with-descriptor ;
 
 : open-pipe ( -- pair )
@@ -82,21 +67,35 @@ M: unix-io run-process* ( desc -- )
 : spawn-process-stream ( -- in out pid )
     open-pipe open-pipe [
         setup-stdio-pipe
-        (spawn-process)
+        spawn-process
     ] [
         -rot 2dup second close first close
-    ] with-fork first swap second rot ;
-
-TUPLE: pipe-stream pid status ;
-
-: <pipe-stream> ( in out pid -- stream )
-    f pipe-stream construct-boa
-    -rot handle>duplex-stream over set-delegate ;
-
-M: pipe-stream stream-close
-    dup delegate stream-close
-    dup pipe-stream-pid wait-for-process
-    swap set-pipe-stream-status ;
+    ] with-fork first swap second rot <process> ;
 
 M: unix-io process-stream*
-    [ spawn-process-stream <pipe-stream> ] with-descriptor ;
+    [
+        spawn-process-stream >r handle>duplex-stream r>
+    ] with-descriptor ;
+
+: find-process ( handle -- process )
+    f process construct-boa processes get at ;
+
+! Inefficient process wait polling, used on Linux and Solaris.
+! On BSD and Mac OS X, we use kqueue() which scales better.
+: wait-for-processes ( -- ? )
+    -1 0 <int> tuck WNOHANG waitpid
+    dup zero? [
+        2drop t
+    ] [
+        find-process dup [
+            >r *uint r> notify-exit f
+        ] [
+            2drop f
+        ] if
+    ] if ;
+
+: wait-loop ( -- )
+    wait-for-processes [ 250 sleep ] when wait-loop ;
+
+: start-wait-thread ( -- )
+    [ wait-loop ] in-thread ;

extra/io/unix/linux/linux.factor

@@ -10,9 +10,6 @@ INSTANCE: linux-io unix-io
 
 M: linux-io init-io ( -- )
     <select-mx> mx set-global
-    start-wait-loop ;
-
-M: linux-io wait-for-process ( pid -- status )
-    wait-for-pid ;
+    start-wait-thread ;
 
 T{ linux-io } set-io-backend

extra/io/windows/launcher/launcher.factor

@@ -6,14 +6,6 @@ math windows.kernel32 windows namespaces io.launcher kernel
 sequences windows.errors assocs splitting system threads init ;
 IN: io.windows.launcher
 
-SYMBOL: processes
-
-[ H{ } clone processes set-global ]
-"io.windows.launcher" add-init-hook
-
-: <win32-process> ( handle -- process )
-    <process> V{ } clone over processes get set-at ;
-
 TUPLE: CreateProcess-args
        lpApplicationName
        lpCommandLine
@@ -104,12 +96,9 @@ M: windows-io run-process* ( desc -- handle )
     [
         make-CreateProcess-args
         dup call-CreateProcess
-        CreateProcess-args-lpProcessInformation <win32-process>
+        CreateProcess-args-lpProcessInformation <process>
     ] with-descriptor ;
 
-M: windows-io wait-for-process*
-    [ processes get at push stop ] curry callcc0 ;
-
 : dispose-process ( process-information -- )
     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
     #! with CloseHandle when they are no longer needed."
@@ -121,11 +110,10 @@ M: windows-io wait-for-process*
     0 <ulong> [ GetExitCodeProcess ] keep *ulong
     swap win32-error=0/f ;
 
-: notify-exit ( process -- )
-    dup process-handle exit-code over set-process-status
-    dup process-handle dispose-process
-    dup processes get delete-at* drop [ schedule-thread ] each
-    f swap set-process-handle ;
+: process-exited ( process -- )
+    dup process-handle exit-code
+    over process-handle dispose-process
+    swap notify-exit ;
 
 : wait-for-processes ( processes -- ? )
     keys dup
@@ -133,7 +121,7 @@ M: windows-io wait-for-process*
     dup length swap >c-void*-array 0 0
     WaitForMultipleObjects
     dup HEX: ffffffff = [ win32-error ] when
-    dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth notify-exit f ] if ;
+    dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
 
 : wait-loop ( -- )
     processes get dup assoc-empty?
@@ -143,3 +131,5 @@ M: windows-io wait-for-process*
 
 : start-wait-thread ( -- )
     [ wait-loop ] in-thread ;
+
+[ start-wait-thread ] "io.windows.launcher" add-init-hook

extra/io/windows/nt/launcher/launcher.factor

@@ -59,6 +59,6 @@ M: windows-io process-stream*
             dup CreateProcess-args-stdout-pipe pipe-in
             over CreateProcess-args-stdin-pipe pipe-out <win32-duplex-stream>
 
-            swap CreateProcess-args-lpProcessInformation <win32-process>
+            swap CreateProcess-args-lpProcessInformation <process>
         ] with-destructors
     ] with-descriptor ;

extra/unix/process/process.factor

@@ -31,25 +31,5 @@ IN: unix.process
 : with-fork ( child parent -- )
     fork dup zero? -roll swap curry if ; inline
 
-! Lame polling strategy for getting process exit codes. On
-! BSD, we use kqueue which is more efficient.
-
-SYMBOL: pid-wait
-
-: (wait-for-pid) ( pid -- status )
-    0 <int> [ 0 waitpid drop ] keep *int ;
-
 : wait-for-pid ( pid -- status )
-    [ pid-wait get-global [ ?push ] change-at stop ] curry
-    callcc1 ;
-
-: wait-loop ( -- )
-    -1 0 <int> tuck WNOHANG waitpid               ! &status return
-    [ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
-    [ schedule-thread-with ] with each
-    250 sleep
-    wait-loop ;
-
-: start-wait-loop ( -- )
-    H{ } clone pid-wait set-global
-    [ wait-loop ] in-thread ;
+    0 <int> [ 0 waitpid drop ] keep *int ;