diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 4aa1353dde..5f1e454dff 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -14,7 +14,7 @@ ;; In the Racket source repo, this version should change only when ;; "racket_version.h" changes: -(define version "8.1.0.3") +(define version "8.1.0.4") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/time.scrbl b/pkgs/racket-doc/scribblings/reference/time.scrbl index 0c10bc559b..7fde7fb559 100644 --- a/pkgs/racket-doc/scribblings/reference/time.scrbl +++ b/pkgs/racket-doc/scribblings/reference/time.scrbl @@ -23,6 +23,24 @@ In this example, @racket[1289513737015] is in milliseconds and @racket[418] is in microseconds.} +@defproc[(current-inexact-monotonic-milliseconds) real?]{ + +Returns the number of milliseconds since an unspecified starting time. +Unlike @racket[current-inexact-milliseconds], which is sensitive to +the system clock and may therefore retreat or advance more quickly +than real time if the system clock is adjusted, results from +@racket[current-inexact-monotonic-milliseconds] will always advance +with real time within a Racket process, but results across processes +are not comparable. + +@examples[(eval:alts +(current-inexact-monotonic-milliseconds) +12772.418 +)] + +@history[#:added "8.1.0.4"]} + + @defproc[(seconds->date [secs-n real?] [local-time? any/c #t]) date*?]{ diff --git a/pkgs/racket-test-core/tests/racket/sync.rktl b/pkgs/racket-test-core/tests/racket/sync.rktl index 77e5b962a5..8237c5fbe3 100644 --- a/pkgs/racket-test-core/tests/racket/sync.rktl +++ b/pkgs/racket-test-core/tests/racket/sync.rktl @@ -8,6 +8,8 @@ (define SYNC-SLEEP-DELAY 0.025) (define SYNC-BUSY-DELAY 0.1) ; go a little slower to check busy waits +(define starting-monotonic-time (current-inexact-monotonic-milliseconds)) + ;; ---------------------------------------- ;; Semaphore peeks @@ -1673,4 +1675,8 @@ ;; ---------------------------------------- +(test #t <= starting-monotonic-time (current-inexact-monotonic-milliseconds)) + +;; ---------------------------------------- + (report-errs) diff --git a/racket/src/bc/src/fun.c b/racket/src/bc/src/fun.c index de4d903a37..e5110fd39d 100644 --- a/racket/src/bc/src/fun.c +++ b/racket/src/bc/src/fun.c @@ -117,6 +117,7 @@ static Scheme_Object *dynamic_wind (int argc, Scheme_Object *argv[]); static Scheme_Object *time_apply(int argc, Scheme_Object *argv[]); static Scheme_Object *current_milliseconds(int argc, Scheme_Object **argv); static Scheme_Object *current_inexact_milliseconds(int argc, Scheme_Object **argv); +static Scheme_Object *current_inexact_monotonic_milliseconds(int argc, Scheme_Object **argv); static Scheme_Object *current_process_milliseconds(int argc, Scheme_Object **argv); static Scheme_Object *current_gc_milliseconds(int argc, Scheme_Object **argv); static Scheme_Object *current_seconds(int argc, Scheme_Object **argv); @@ -487,6 +488,11 @@ scheme_init_fun (Scheme_Startup_Env *env) "current-inexact-milliseconds", 0, 0), env); + scheme_addto_prim_instance("current-inexact-monotonic-milliseconds", + scheme_make_immed_prim(current_inexact_monotonic_milliseconds, + "current-inexact-monotonic-milliseconds", + 0, 0), + env); scheme_addto_prim_instance("current-process-milliseconds", scheme_make_immed_prim(current_process_milliseconds, "current-process-milliseconds", @@ -9772,6 +9778,12 @@ double scheme_get_inexact_milliseconds(void) return rktio_get_inexact_milliseconds(); } +static double get_inexact_monotonic_milliseconds(void) +/* this function can be called from any OS thread */ +{ + return rktio_get_inexact_monotonic_milliseconds(scheme_rktio); +} + intptr_t scheme_get_process_milliseconds(void) { return rktio_get_process_milliseconds(scheme_rktio); @@ -9886,7 +9898,7 @@ static Scheme_Object *seconds_to_date(int argc, Scheme_Object **argv) static Scheme_Object *time_apply(int argc, Scheme_Object *argv[]) { - uintptr_t start, end; + double start, end; uintptr_t cpustart, cpuend; uintptr_t gcstart, gcend; uintptr_t dur, cpudur, gcdur; @@ -9922,14 +9934,14 @@ static Scheme_Object *time_apply(int argc, Scheme_Object *argv[]) } gcstart = scheme_total_gc_time; - start = scheme_get_milliseconds(); + start = get_inexact_monotonic_milliseconds(); cpustart = scheme_get_process_milliseconds(); v = _scheme_apply_multi(argv[0], num_rands, rand_vec); cpuend = scheme_get_process_milliseconds(); - end = scheme_get_milliseconds(); + end = get_inexact_monotonic_milliseconds(); gcend = scheme_total_gc_time; - dur = end - start; + dur = (uintptr_t)(end - start); cpudur = cpuend - cpustart; gcdur = gcend - gcstart; @@ -9962,6 +9974,11 @@ static Scheme_Object *current_inexact_milliseconds(int argc, Scheme_Object **arg return scheme_make_double(scheme_get_inexact_milliseconds()); } +static Scheme_Object *current_inexact_monotonic_milliseconds(int argc, Scheme_Object **argv) +{ + return scheme_make_double(get_inexact_monotonic_milliseconds()); +} + static Scheme_Object *current_process_milliseconds(int argc, Scheme_Object **argv) { if (!argc || SCHEME_FALSEP(argv[0])) diff --git a/racket/src/bc/src/schminc.h b/racket/src/bc/src/schminc.h index dc3a6b0355..a89c99590d 100644 --- a/racket/src/bc/src/schminc.h +++ b/racket/src/bc/src/schminc.h @@ -15,7 +15,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1503 +#define EXPECTED_PRIM_COUNT 1504 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index 70a619065a..a1485cb30e 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/racket/src/cs/primitive/kernel.ss @@ -215,6 +215,7 @@ [current-gc-milliseconds (known-procedure/no-prompt 1)] [current-get-interaction-input-port (known-procedure/single-valued 3)] [current-inexact-milliseconds (known-procedure/no-prompt 1)] + [current-inexact-monotonic-milliseconds (known-procedure/no-prompt 1)] [current-input-port (known-procedure/single-valued 3)] [current-inspector (known-procedure/single-valued 3)] [current-load-extension (known-procedure/single-valued 3)] diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 6826542ea5..e7e5f5b84f 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -477,6 +477,7 @@ time-apply current-inexact-milliseconds + current-inexact-monotonic-milliseconds current-milliseconds current-gc-milliseconds current-seconds diff --git a/racket/src/cs/rumble/time.ss b/racket/src/cs/rumble/time.ss index 02ae267e97..f29a2260d4 100644 --- a/racket/src/cs/rumble/time.ss +++ b/racket/src/cs/rumble/time.ss @@ -101,6 +101,9 @@ (define (current-inexact-milliseconds) (time->ms (current-time 'time-utc))) +(define (current-inexact-monotonic-milliseconds) + (time->ms (current-time 'time-monotonic))) + (define (current-seconds) (let ((t (current-time 'time-utc))) (time-second t))) diff --git a/racket/src/rktio/rktio.def b/racket/src/rktio/rktio.def index 1171a650b2..382221a65b 100644 --- a/racket/src/rktio/rktio.def +++ b/racket/src/rktio/rktio.def @@ -170,6 +170,7 @@ rktio_poll_os_signal rktio_will_modify_os_signal_handler rktio_get_milliseconds rktio_get_inexact_milliseconds +rktio_get_inexact_monotonic_milliseconds rktio_get_process_milliseconds rktio_get_process_children_milliseconds rktio_get_seconds diff --git a/racket/src/rktio/rktio.h b/racket/src/rktio/rktio.h index 98687d058c..09c9c3fdb8 100644 --- a/racket/src/rktio/rktio.h +++ b/racket/src/rktio/rktio.h @@ -1062,16 +1062,21 @@ typedef struct rktio_date_t { } rktio_date_t; RKTIO_EXTERN_NOERR uintptr_t rktio_get_milliseconds(void); -/* Overflow may cause the result to wrap around to 0, at least on a - 32-bit platform. */ +/* Wll-clock time. Overflow may cause the result to wrap around to 0, + at least on a 32-bit platform. */ RKTIO_EXTERN_NOERR double rktio_get_inexact_milliseconds(void); -/* No overflow, but won't strictly increase if the system clock is reset. */ +/* Wall-clock time. No overflow, but won't strictly increase if the + system clock is reset. */ + +RKTIO_EXTERN_NOERR double rktio_get_inexact_monotonic_milliseconds(rktio_t *rktio); +/* Real time like wall-clock time, but will strictly increase, + assuming that the host system provides a monotonic clock. */ RKTIO_EXTERN_NOERR uintptr_t rktio_get_process_milliseconds(rktio_t *rktio); RKTIO_EXTERN_NOERR uintptr_t rktio_get_process_children_milliseconds(rktio_t *rktio); -/* Overflow may cause the result to wrap around to 0, at least on a - 32-bit platform. */ +/* CPU time across all threads withing the process. Overflow may cause + the result to wrap around to 0, at least on a 32-bit platform. */ RKTIO_EXTERN_NOERR rktio_timestamp_t rktio_get_seconds(rktio_t *rktio); RKTIO_EXTERN rktio_date_t *rktio_seconds_to_date(rktio_t *rktio, rktio_timestamp_t seconds, int nanoseconds, int get_gmt); diff --git a/racket/src/rktio/rktio.inc b/racket/src/rktio/rktio.inc index d2c5dc2e66..ba91d4b911 100644 --- a/racket/src/rktio/rktio.inc +++ b/racket/src/rktio/rktio.inc @@ -170,6 +170,7 @@ Sforeign_symbol("rktio_poll_os_signal", (void *)rktio_poll_os_signal); Sforeign_symbol("rktio_will_modify_os_signal_handler", (void *)rktio_will_modify_os_signal_handler); Sforeign_symbol("rktio_get_milliseconds", (void *)rktio_get_milliseconds); Sforeign_symbol("rktio_get_inexact_milliseconds", (void *)rktio_get_inexact_milliseconds); +Sforeign_symbol("rktio_get_inexact_monotonic_milliseconds", (void *)rktio_get_inexact_monotonic_milliseconds); Sforeign_symbol("rktio_get_process_milliseconds", (void *)rktio_get_process_milliseconds); Sforeign_symbol("rktio_get_process_children_milliseconds", (void *)rktio_get_process_children_milliseconds); Sforeign_symbol("rktio_get_seconds", (void *)rktio_get_seconds); diff --git a/racket/src/rktio/rktio.rktl b/racket/src/rktio/rktio.rktl index 0dce830e83..d09dd441b5 100644 --- a/racket/src/rktio/rktio.rktl +++ b/racket/src/rktio/rktio.rktl @@ -1220,6 +1220,11 @@ (define-function () void rktio_will_modify_os_signal_handler ((int sig_id))) (define-function () uintptr_t rktio_get_milliseconds ()) (define-function () double rktio_get_inexact_milliseconds ()) +(define-function + () + double + rktio_get_inexact_monotonic_milliseconds + (((ref rktio_t) rktio))) (define-function () uintptr_t diff --git a/racket/src/rktio/rktio_private.h b/racket/src/rktio/rktio_private.h index e36e223e89..cdeacad4b6 100644 --- a/racket/src/rktio/rktio_private.h +++ b/racket/src/rktio/rktio_private.h @@ -70,6 +70,8 @@ struct rktio_t { struct rktio_socket_t *wsr_array; int made_progress; DWORD max_sleep_time; + int got_hires_freq; + LARGE_INTEGER hires_freq; #endif #ifdef USE_FAR_RKTIO_FDCALLS /* A single fdset that can be reused for immediate actions: */ diff --git a/racket/src/rktio/rktio_time.c b/racket/src/rktio/rktio_time.c index 4ba8b64d6e..55400d37cd 100644 --- a/racket/src/rktio/rktio_time.c +++ b/racket/src/rktio/rktio_time.c @@ -107,6 +107,42 @@ double rktio_get_inexact_milliseconds(void) #endif } +double rktio_get_inexact_monotonic_milliseconds(rktio_t *rktio) +{ +#ifdef RKTIO_SYSTEM_WINDOWS + if (!rktio->got_hires_freq) { + if (!QueryPerformanceFrequency(&rktio->hires_freq)) + rktio->hires_freq.QuadPart = 0; + rktio->got_hires_freq = 1; + } + + if (rktio->hires_freq.QuadPart != 0) { + LARGE_INTEGER count; + if (QueryPerformanceCounter(&count)) + return ((double)count.QuadPart * 1000.0) / (double)rktio->hires_freq.QuadPart; + } +#else +# ifdef CLOCK_MONOTONIC_HR +# define RKTIO_CLOCK_MONOTONIC CLOCK_MONOTONIC_HR +# endif +# ifdef CLOCK_MONOTONIC +# define RKTIO_CLOCK_MONOTONIC CLOCK_MONOTONIC +# endif +# ifdef CLOCK_HIGHRES +# define RKTIO_CLOCK_MONOTONIC CLOCK_HIGHRES +# endif +# ifdef RKTIO_CLOCK_MONOTONIC + { + struct timespec tp; + if (clock_gettime(RKTIO_CLOCK_MONOTONIC, &tp) == 0) + return (double)tp.tv_sec * 1000.0 + (double)tp.tv_nsec / 1000000.0; + } +# endif +#endif + /* fallback: */ + return rktio_get_inexact_milliseconds(); +} + uintptr_t rktio_get_process_milliseconds(rktio_t *rktio) { #ifdef USER_TIME_IS_CLOCK diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index 7c1097c42e..f1ce28334f 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 8 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 3 +#define MZSCHEME_VERSION_W 4 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x