From 6afa4119c8e3519e182b2163bd0402c79ba5cec4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 04:19:15 -0400 Subject: [PATCH] Clean up non-blocking wait-for-process support, implement on Unix (untested) --- extra/io/launcher/launcher.factor | 29 +++++++-- extra/io/unix/bsd/bsd.factor | 4 +- extra/io/unix/kqueue/kqueue.factor | 18 ++---- extra/io/unix/launcher/launcher.factor | 63 ++++++++++---------- extra/io/unix/linux/linux.factor | 5 +- extra/io/windows/launcher/launcher.factor | 26 +++----- extra/io/windows/nt/launcher/launcher.factor | 2 +- extra/unix/process/process.factor | 22 +------ 8 files changed, 72 insertions(+), 97 deletions(-) mode change 100644 => 100755 extra/io/unix/kqueue/kqueue.factor mode change 100644 => 100755 extra/unix/process/process.factor diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index decf4f3434..c646358b2e 100755 --- a/extra/io/launcher/launcher.factor +++ b/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 ; -: ( handle -- process ) f process construct-boa ; +HOOK: register-process io-backend ( process -- ) + +M: object register-process drop ; + +: ( 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 [ 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 ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 39eb8b6fb9..3319324c3d 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/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 diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor old mode 100644 new mode 100755 index 4fbfbcaaf0..3df2d7cd57 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/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 ; : ( -- mx ) kqueue-mx construct-mx kqueue dup io-error over set-mx-fd - H{ } clone over set-kqueue-mx-processes max-events "kevent" 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 ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index adf571a8b7..3cd21e6c51 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/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 ] 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 ; - -: ( 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 ; M: unix-io process-stream* - [ spawn-process-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 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 ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 06380c7e1e..fcb48dd577 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -10,9 +10,6 @@ INSTANCE: linux-io unix-io M: linux-io init-io ( -- ) 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 diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 603fa2a638..79284b265b 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/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 - -: ( handle -- 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 + CreateProcess-args-lpProcessInformation ] 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 [ 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 diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 6e788003ea..bfce92e17d 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/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 - swap CreateProcess-args-lpProcessInformation + swap CreateProcess-args-lpProcessInformation ] with-destructors ] with-descriptor ; diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor old mode 100644 new mode 100755 index b2877dc4a1..fb4271ea23 --- a/extra/unix/process/process.factor +++ b/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 [ 0 waitpid drop ] keep *int ; - : wait-for-pid ( pid -- status ) - [ pid-wait get-global [ ?push ] change-at stop ] curry - callcc1 ; - -: wait-loop ( -- ) - -1 0 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 ; \ No newline at end of file + 0 [ 0 waitpid drop ] keep *int ; \ No newline at end of file