From 627c775b6fc3345a2937667aa9d339bfd9921540 Mon Sep 17 00:00:00 2001 From: Leif Andersen Date: Wed, 29 Oct 2014 16:50:23 -0400 Subject: [PATCH] Add 'subprocesses mode to `current-process-milliseconds` --- .../racket-doc/scribblings/inside/misc.scrbl | 6 ++- .../scribblings/reference/time.scrbl | 32 +++++++++---- .../racket-test/tests/racket/thread.rktl | 6 +++ racket/src/racket/include/mzwin.def | 1 + racket/src/racket/include/mzwin3m.def | 1 + racket/src/racket/include/racket.exp | 1 + racket/src/racket/include/racket3m.exp | 1 + racket/src/racket/src/fun.c | 46 ++++++++++++++++++- racket/src/racket/src/port.c | 41 +++++++++++++++-- racket/src/racket/src/schemef.h | 1 + racket/src/racket/src/schemex.h | 1 + racket/src/racket/src/schemex.inc | 1 + racket/src/racket/src/schemexm.h | 1 + racket/src/racket/src/schpriv.h | 3 ++ 14 files changed, 129 insertions(+), 13 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/inside/misc.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/inside/misc.scrbl index 9748a10f7d..eeb381878e 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/inside/misc.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/inside/misc.scrbl @@ -326,7 +326,11 @@ Returns the current ``time'' in milliseconds, just like @function[(intptr_t scheme_get_process_milliseconds)]{ Returns the current process ``time'' in milliseconds, just like -@racket[current-process-milliseconds].} +@racket[(current-process-milliseconds)].} + +@function[(intptr_t scheme_get_process_children_milliseconds)]{ +Returns the current process group ``time'' in milliseconds just like +@racket[(current-process-milliseconds 'subprocesses)].} @function[(char* scheme_banner)]{ diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/time.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/time.scrbl index 15fa619e38..67edd8e6e3 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/time.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/time.scrbl @@ -99,18 +99,34 @@ Like @racket[current-inexact-milliseconds], but coerced to a reasonably long) time on a 32-bit platform.} -@defproc[(current-process-milliseconds [thread (or/c thread? #f)]) +@defproc[(current-process-milliseconds [scope (or/c #f thread? 'subprocesses) #f]) exact-integer?]{ -Returns an amount of processor time in @tech{fixnum} milliseconds -that has been consumed by the Racket process on the underlying -operating system. (On @|AllUnix|, this includes both user and -system time.) If @racket[thread] is @racket[#f], the reported time -is for all Racket threads, otherwise the result is specific to the -time while @racket[thread] ran. +Returns an amount of processor time in @tech{fixnum} milliseconds that +has been consumed by on the underlying operating system, including +both user and system time. + +@itemlist[ + + @item{If @racket[scope] is @racket[#f], the reported time is for all + Racket threads and @tech{places}.} + + @item{If @racket[scope] is a thread, the result is specific to the + time while the thread ran, but it may include time for other + @tech{places}.} + + @item{If @racket[scope] is @racket['subprocesses], the result is the + sum of process times for known-completed subprocesses (see + @secref["subprocess"])---and known-completed children of the + subprocesses, etc., on @|AllUnix|---across all @tech{places}.} + +] + The precision of the result is platform-specific, and since the result is a @tech{fixnum}, the value increases only over a -limited (though reasonably long) time on a 32-bit platform.} +limited (though reasonably long) time on a 32-bit platform. + +@history[#:changed "6.1.1.4" @elem{Added @racket['subprocesses] mode.}]} @defproc[(current-gc-milliseconds) exact-integer?]{ diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/thread.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/thread.rktl index ebf538417a..6edb20cb89 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/thread.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/thread.rktl @@ -1545,6 +1545,12 @@ (kill-thread t) (test #t positive? s)) +(test #t integer? (current-process-milliseconds)) +(test #t integer? (current-process-milliseconds #f)) +(test #t integer? (current-process-milliseconds (thread void))) +(test #t integer? (current-process-milliseconds 'subprocesses)) +(err/rt-test (current-process-milliseconds 'other)) + ; -------------------- (report-errs) diff --git a/racket/src/racket/include/mzwin.def b/racket/src/racket/include/mzwin.def index da4a740a0f..67733f1b38 100644 --- a/racket/src/racket/include/mzwin.def +++ b/racket/src/racket/include/mzwin.def @@ -613,6 +613,7 @@ EXPORTS scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds + scheme_get_process_children_milliseconds scheme_get_thread_milliseconds scheme_banner scheme_version diff --git a/racket/src/racket/include/mzwin3m.def b/racket/src/racket/include/mzwin3m.def index 7f679de91d..18fe63c9d6 100644 --- a/racket/src/racket/include/mzwin3m.def +++ b/racket/src/racket/include/mzwin3m.def @@ -629,6 +629,7 @@ EXPORTS scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds + scheme_get_process_children_milliseconds scheme_get_thread_milliseconds scheme_banner scheme_version diff --git a/racket/src/racket/include/racket.exp b/racket/src/racket/include/racket.exp index 88d46c806f..d8ae7beda4 100644 --- a/racket/src/racket/include/racket.exp +++ b/racket/src/racket/include/racket.exp @@ -629,6 +629,7 @@ scheme_get_seconds scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds +scheme_get_process_children_milliseconds scheme_get_thread_milliseconds scheme_banner scheme_version diff --git a/racket/src/racket/include/racket3m.exp b/racket/src/racket/include/racket3m.exp index 79f600736c..cb1a958ef4 100644 --- a/racket/src/racket/include/racket3m.exp +++ b/racket/src/racket/include/racket3m.exp @@ -636,6 +636,7 @@ scheme_get_seconds scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds +scheme_get_process_children_milliseconds scheme_get_thread_milliseconds scheme_banner scheme_version diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 330f0016f4..ef7cac6517 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -64,6 +64,9 @@ # ifdef WINDOWS_GET_PROCESS_TIMES # include # endif +# if !defined(USE_GETRUSAGE) && !defined(WINDOWS_GET_PROCESS_TIMES) && !defined(USER_TIME_IS_CLOCK) +# include +# endif # endif /* USE_PALMTIME */ # endif /* USE_MACTIME */ #endif /* TIME_SYNTAX */ @@ -102,6 +105,7 @@ ROSYM static Scheme_Object *transparent_symbol; ROSYM static Scheme_Object *transparent_binding_symbol; ROSYM static Scheme_Object *opaque_symbol; ROSYM static Scheme_Object *none_symbol; +ROSYM static Scheme_Object *subprocesses_symbol; ROSYM static Scheme_Object *is_method_symbol; ROSYM static Scheme_Object *cont_key; /* uninterned */ ROSYM static Scheme_Object *barrier_prompt_key; /* uninterned */ @@ -124,6 +128,10 @@ THREAD_LOCAL_DECL(static Scheme_Overflow *offstack_overflow); THREAD_LOCAL_DECL(int scheme_cont_capture_count); THREAD_LOCAL_DECL(static int scheme_prompt_capture_count); +#ifdef WINDOWS_GET_PROCESS_TIMES +SHARED_OK volatile uintptr_t scheme_process_children_msecs; +#endif + /* locals */ static Scheme_Object *procedure_p (int argc, Scheme_Object *argv[]); static Scheme_Object *apply (int argc, Scheme_Object *argv[]); @@ -652,6 +660,9 @@ scheme_init_fun (Scheme_Env *env) opaque_symbol = scheme_intern_symbol("opaque"); none_symbol = scheme_intern_symbol("none"); + REGISTER_SO(subprocesses_symbol); + subprocesses_symbol = scheme_intern_symbol("subprocesses"); + REGISTER_SO(is_method_symbol); REGISTER_SO(cont_key); REGISTER_SO(barrier_prompt_key); @@ -9393,6 +9404,37 @@ intptr_t scheme_get_process_milliseconds(void) #endif } +intptr_t scheme_get_process_children_milliseconds(void) + XFORM_SKIP_PROC +{ +#ifdef USER_TIME_IS_CLOCK + return 0; +#else +# ifdef USE_GETRUSAGE + struct rusage use; + intptr_t s, u; + + do { + if (!getrusage(RUSAGE_CHILDREN, &use)) + break; + } while (errno == EINTR); + + s = use.ru_utime.tv_sec + use.ru_stime.tv_sec; + u = use.ru_utime.tv_usec + use.ru_stime.tv_usec; + + return (s * 1000 + u / 1000); +# else +# ifdef WINDOWS_GET_PROCESS_TIMES + return (intptr_t)scheme_process_children_msecs; +# else + clock_t t; + times(&t); + return (t.tms_cutime + t.tms_cstime) * 1000 / CLK_TCK; +# endif +# endif +#endif +} + intptr_t scheme_get_thread_milliseconds(Scheme_Object *thrd) XFORM_SKIP_PROC { @@ -9845,10 +9887,12 @@ static Scheme_Object *current_process_milliseconds(int argc, Scheme_Object **arg { if (!argc || SCHEME_FALSEP(argv[0])) return scheme_make_integer(scheme_get_process_milliseconds()); + else if (SAME_OBJ(argv[0], subprocesses_symbol)) + return scheme_make_integer(scheme_get_process_children_milliseconds()); else { if (SCHEME_THREADP(argv[0])) return scheme_make_integer(scheme_get_thread_milliseconds(argv[0])); - scheme_wrong_contract("current-process-milliseconds", "thread?", 0, argc, argv); + scheme_wrong_contract("current-process-milliseconds", "(or/c #f thread? 'subprocesses)", 0, argc, argv); return NULL; } } diff --git a/racket/src/racket/src/port.c b/racket/src/racket/src/port.c index 7f357783f3..e7ad356739 100644 --- a/racket/src/racket/src/port.c +++ b/racket/src/racket/src/port.c @@ -198,6 +198,9 @@ typedef struct Scheme_Subprocess { #if defined(MZ_PLACES_WAITPID) short done; int status; +#endif +#ifdef WINDOWS_GET_PROCESS_TIMES + int got_time; #endif Scheme_Custodian_Reference *mref; } Scheme_Subprocess; @@ -9128,6 +9131,35 @@ static Scheme_Object *redirect_get_or_peek_bytes_k(void) #if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES) +#if defined(WINDOWS_PROCESSES) +static void collect_process_time(DWORD w, Scheme_Subprocess *sp) +{ + if ((w != STILL_ACTIVE) && !sp->got_time) { + FILETIME cr, ex, kr, us; + if (GetProcessTimes(sp->handle, &cr, &ex, &kr, &us)) { + mzlonglong v; + uintptr_t msecs; + v = ((((mzlonglong)kr.dwHighDateTime << 32) + kr.dwLowDateTime) + + (((mzlonglong)us.dwHighDateTime << 32) + us.dwLowDateTime)); + msecs = (uintptr_t)(v / 10000); + +#if defined(MZ_USE_PLACES) + { + int set = 0; + while (!set) { + uintptr_t old_val = scheme_process_children_msecs; + set = mzrt_cas(&scheme_process_children_msecs, old_val, old_val + msecs); + } + } +#else + scheme_process_children_msecs += msecs; +#endif + } + sp->got_time = 1; + } +} +#endif + static void child_mref_done(Scheme_Subprocess *sp) { if (sp->mref) { @@ -9176,9 +9208,10 @@ static int subp_done(Scheme_Object *so) HANDLE sci = (HANDLE) ((Scheme_Subprocess *)sp)->handle; DWORD w; if (sci) { - if (GetExitCodeProcess(sci, &w)) - return w != STILL_ACTIVE; - else + if (GetExitCodeProcess(sci, &w)) { + collect_process_time(w, (Scheme_Subprocess *)sp); + return (w != STILL_ACTIVE); + } else return 1; } else return 1; @@ -9236,6 +9269,7 @@ static Scheme_Object *subprocess_status(int argc, Scheme_Object **argv) DWORD w; if (sp->handle) { if (GetExitCodeProcess((HANDLE)sp->handle, &w)) { + collect_process_time(w, sp); if (w == STILL_ACTIVE) going = 1; else @@ -9362,6 +9396,7 @@ static Scheme_Object *do_subprocess_kill(Scheme_Object *_sp, Scheme_Object *kill if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, sp->pid)) return scheme_void; } else if (GetExitCodeProcess((HANDLE)sp->handle, &w)) { + collect_process_time(w, sp); if (w != STILL_ACTIVE) return scheme_void; if (TerminateProcess((HANDLE)sp->handle, 1)) diff --git a/racket/src/racket/src/schemef.h b/racket/src/racket/src/schemef.h index 75a03665ca..8acc2aec85 100644 --- a/racket/src/racket/src/schemef.h +++ b/racket/src/racket/src/schemef.h @@ -1191,6 +1191,7 @@ MZ_EXTERN intptr_t scheme_get_seconds(void); XFORM_NONGCING MZ_EXTERN intptr_t scheme_get_milliseconds(void); XFORM_NONGCING MZ_EXTERN double scheme_get_inexact_milliseconds(void); XFORM_NONGCING MZ_EXTERN intptr_t scheme_get_process_milliseconds(void); +XFORM_NONGCING MZ_EXTERN intptr_t scheme_get_process_children_milliseconds(void); XFORM_NONGCING MZ_EXTERN intptr_t scheme_get_thread_milliseconds(Scheme_Object *thrd); MZ_EXTERN char *scheme_banner(void); diff --git a/racket/src/racket/src/schemex.h b/racket/src/racket/src/schemex.h index 97dcfd9b4e..f0ec4b2cb6 100644 --- a/racket/src/racket/src/schemex.h +++ b/racket/src/racket/src/schemex.h @@ -975,6 +975,7 @@ intptr_t (*scheme_get_seconds)(void); intptr_t (*scheme_get_milliseconds)(void); double (*scheme_get_inexact_milliseconds)(void); intptr_t (*scheme_get_process_milliseconds)(void); +intptr_t (*scheme_get_process_children_milliseconds)(void); intptr_t (*scheme_get_thread_milliseconds)(Scheme_Object *thrd); char *(*scheme_banner)(void); char *(*scheme_version)(void); diff --git a/racket/src/racket/src/schemex.inc b/racket/src/racket/src/schemex.inc index 3ef9946405..9e937caeff 100644 --- a/racket/src/racket/src/schemex.inc +++ b/racket/src/racket/src/schemex.inc @@ -702,6 +702,7 @@ scheme_extension_table->scheme_get_milliseconds = scheme_get_milliseconds; scheme_extension_table->scheme_get_inexact_milliseconds = scheme_get_inexact_milliseconds; scheme_extension_table->scheme_get_process_milliseconds = scheme_get_process_milliseconds; + scheme_extension_table->scheme_get_process_children_milliseconds = scheme_get_process_children_milliseconds; scheme_extension_table->scheme_get_thread_milliseconds = scheme_get_thread_milliseconds; scheme_extension_table->scheme_banner = scheme_banner; scheme_extension_table->scheme_version = scheme_version; diff --git a/racket/src/racket/src/schemexm.h b/racket/src/racket/src/schemexm.h index aaf2ede556..6fd65edfa4 100644 --- a/racket/src/racket/src/schemexm.h +++ b/racket/src/racket/src/schemexm.h @@ -702,6 +702,7 @@ #define scheme_get_milliseconds (scheme_extension_table->scheme_get_milliseconds) #define scheme_get_inexact_milliseconds (scheme_extension_table->scheme_get_inexact_milliseconds) #define scheme_get_process_milliseconds (scheme_extension_table->scheme_get_process_milliseconds) +#define scheme_get_process_children_milliseconds (scheme_extension_table->scheme_get_process_children_milliseconds) #define scheme_get_thread_milliseconds (scheme_extension_table->scheme_get_thread_milliseconds) #define scheme_banner (scheme_extension_table->scheme_banner) #define scheme_version (scheme_extension_table->scheme_version) diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 9dcdb33f25..99e1a9f1cb 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -645,6 +645,9 @@ void scheme_block_child_signals(int block); void scheme_check_child_done(void); int scheme_extract_child_status(int status); #endif +#ifdef WINDOWS_GET_PROCESS_TIMES +extern volatile uintptr_t scheme_process_children_msecs; +#endif void scheme_prepare_this_thread_for_GC(Scheme_Thread *t);