steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

io.launcher: wait for new processes faster. 

This starts at 5 milliseconds, then backs off 5 milliseconds at a time,
until 100 milliseconds. In case the processes are short-lived, they
will be detected sooner, and long-running processes will still be checked
at intervals of 100 millseconds like before.
char-rename
John Benediktsson 2016-11-27 07:35:26 -08:00
parent 463b57f7c9
commit 7465bd0ed6
1 changed files with 19 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
basis/io/launcher/launcher.factor
View File

@ -4,8 +4,8 @@
USING: accessors assocs calendar combinators concurrency.flags USING: accessors assocs calendar combinators concurrency.flags
debugger destructors environment fry init io io.backend debugger destructors environment fry init io io.backend
io.encodings io.encodings.utf8 io.pipes io.pipes.private io.encodings io.encodings.utf8 io.pipes io.pipes.private
io.ports io.streams.duplex io.timeouts kernel namespaces io.ports io.streams.duplex io.timeouts kernel math math.order
prettyprint sequences strings system threads vocabs ; namespaces prettyprint sequences strings system threads vocabs ;
IN: io.launcher IN: io.launcher
@ -74,14 +74,23 @@ HOOK: (wait-for-processes) io-backend ( -- ? )
<PRIVATE <PRIVATE
SYMBOL: wait-flag SYMBOL: wait-flag
SYMBOL: wait-delay
: wait-loop ( -- ) : wait-loop ( -- )
processes get assoc-empty? processes get assoc-empty? [
[ wait-flag get-global lower-flag ] 5 wait-delay set-global
[ (wait-for-processes) [ 100 milliseconds sleep ] when ] if ; wait-flag get-global lower-flag
] [
(wait-for-processes) [
wait-delay [
[ milliseconds sleep ] [ 5 + 100 max ] bi
] change-global
] when
] if ;
: start-wait-thread ( -- ) : start-wait-thread ( -- )
<flag> wait-flag set-global <flag> wait-flag set-global
5 wait-delay set-global
[ wait-loop t ] "Process wait" spawn-server drop ; [ wait-loop t ] "Process wait" spawn-server drop ;
[ [
@ -94,6 +103,11 @@ SYMBOL: wait-flag
V{ } clone swap processes get set-at V{ } clone swap processes get set-at
wait-flag get-global raise-flag ; wait-flag get-global raise-flag ;
: notify-exit ( process status -- )
>>status
[ processes get delete-at* drop [ resume ] each ] keep
f >>handle drop ;
: pass-environment? ( process -- ? ) : pass-environment? ( process -- ? )
dup environment>> assoc-empty? not dup environment>> assoc-empty? not
swap environment-mode>> +replace-environment+ eq? or ; swap environment-mode>> +replace-environment+ eq? or ;
@ -296,16 +310,6 @@ M: output-process-error error.
[ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
0 = [ 2drop ] [ output-process-error ] if ; 0 = [ 2drop ] [ output-process-error ] if ;
<PRIVATE
: notify-exit ( process status -- )
>>status
[ processes get delete-at* drop [ resume ] each ] keep
f >>handle
drop ;
PRIVATE>
{ {
{ [ os unix? ] [ "io.launcher.unix" require ] } { [ os unix? ] [ "io.launcher.unix" require ] }
{ [ os windows? ] [ "io.launcher.windows" require ] } { [ os windows? ] [ "io.launcher.windows" require ] }