add current-inexact-monotonic-milliseconds

Closes #1826

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]))

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*?]{

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)

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]))

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

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)]

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

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)))

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

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);

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);

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

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: */

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

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