From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 14 May 2018 04:20:23 +0000 (-0700)
Subject: Implement CURRENT-JIFFY and JIFFIES-PER-SECOND for R7RS.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~45
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=16b5b13b16b3023d2e11b7054eb9eaad2fe2100b;p=mit-scheme.git

Implement CURRENT-JIFFY and JIFFIES-PER-SECOND for R7RS.

Very rough implementation, may return process time instead of real time on
non-POSIX systems.
---

diff --git a/src/microcode/ntenv.c b/src/microcode/ntenv.c
index 4085eae00..f7548dbad 100644
--- a/src/microcode/ntenv.c
+++ b/src/microcode/ntenv.c
@@ -197,6 +197,18 @@ OS_real_time_clock (void)
 {
   return ((((double) (clock ())) * 1000.0) / ((double) CLOCKS_PER_SEC));
 }
+
+clock_t
+OS_current_jiffy (void)
+{
+  return (clock ());
+}
+
+clock_t
+OS_jiffies_per_second (void)
+{
+  return (CLOCKS_PER_SEC);
+}
 
 /* The timers are all the same.
    This just provides three distinct timers.
diff --git a/src/microcode/osenv.h b/src/microcode/osenv.h
index 3afce7e63..0c3915873 100644
--- a/src/microcode/osenv.h
+++ b/src/microcode/osenv.h
@@ -73,5 +73,7 @@ extern void OS_real_timer_set (clock_t, clock_t);
 extern void OS_real_timer_clear (void);
 extern const char * OS_working_dir_pathname (void);
 extern void OS_set_working_dir_pathname (const char *);
+extern clock_t OS_current_jiffy (void);
+extern clock_t OS_jiffies_per_second (void);
 
 #endif /* SCM_OSENV_H */
diff --git a/src/microcode/prosenv.c b/src/microcode/prosenv.c
index baf186454..4344a8e72 100644
--- a/src/microcode/prosenv.c
+++ b/src/microcode/prosenv.c
@@ -137,6 +137,19 @@ DEFINE_PRIMITIVE ("REAL-TIME-CLOCK", Prim_real_time_clock, 0, 0,
   PRIMITIVE_RETURN (double_to_integer (OS_real_time_clock ()));
 }
 
+DEFINE_PRIMITIVE ("CURRENT-JIFFY", Prim_current_jiffy, 0, 0, 0)
+{
+  PRIMITIVE_HEADER (0);
+  clock_t n = (OS_current_jiffy ());
+  PRIMITIVE_RETURN ((n < 0) ? SHARP_F : (intmax_to_integer (n)));
+}
+
+DEFINE_PRIMITIVE ("JIFFIES-PER-SECOND", Prim_jiffies_per_second, 0, 0, 0)
+{
+  PRIMITIVE_HEADER (0);
+  PRIMITIVE_RETURN (intmax_to_integer (OS_jiffies_per_second ()));
+}
+
 DEFINE_PRIMITIVE ("PROCESS-TIMER-CLEAR", Prim_process_timer_clear, 0, 0,
   "Turn off the process timer.")
 {
diff --git a/src/microcode/uxenv.c b/src/microcode/uxenv.c
index b91a15840..70ccf5eaa 100644
--- a/src/microcode/uxenv.c
+++ b/src/microcode/uxenv.c
@@ -498,6 +498,43 @@ OS_real_time_clock (void)
 
 #endif /* HAVE_TIMES */
 #endif /* HAVE_GETTIMEOFDAY */
+
+/* current-jiffy and jiffies-per-second */
+
+#ifdef HAVE_TIMES
+
+clock_t
+OS_current_jiffy (void)
+{
+  struct tms buffer;
+  return (UX_times (&buffer));
+}
+
+clock_t
+OS_jiffies_per_second (void)
+{
+#ifdef __APPLE__
+  return (CLK_TCK);
+#else
+  return (CLOCKS_PER_SEC);
+#endif
+}
+
+#else /* not HAVE_TIMES */
+
+clock_t
+OS_current_jiffy (void)
+{
+  return (clock ());
+}
+
+clock_t
+OS_jiffies_per_second (void)
+{
+  return (CLOCKS_PER_SEC);
+}
+
+#endif /* HAVE_TIMES */
 
 #ifdef HAVE_SETITIMER
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c27f52229..237190710 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4820,8 +4820,10 @@ USA.
   (files "sysclk")
   (parent (runtime))
   (export ()
+	  current-jiffy
 	  internal-time/seconds->ticks
 	  internal-time/ticks->seconds
+	  jiffies-per-second
 	  measure-interval
 	  process-time-clock
 	  real-time-clock
diff --git a/src/runtime/sysclk.scm b/src/runtime/sysclk.scm
index 13d8b0bff..4bc7b81a4 100644
--- a/src/runtime/sysclk.scm
+++ b/src/runtime/sysclk.scm
@@ -35,7 +35,11 @@ USA.
 
 (define (reset-system-clock!)
   (set! offset-time (process-time-clock))
-  (set! non-runtime 0))
+  (set! non-runtime 0)
+  unspecific)
+
+(define current-jiffy (ucode-primitive current-jiffy 0))
+(define jiffies-per-second (ucode-primitive jiffies-per-second 0))
 
 (define offset-time)
 (define non-runtime)
@@ -53,7 +57,8 @@ USA.
   (process->system-time (- (process-time-clock) non-runtime)))
 
 (define (increment-non-runtime! ticks)
-  (set! non-runtime (+ non-runtime ticks)))
+  (set! non-runtime (+ non-runtime ticks))
+  unspecific)
 
 (define (measure-interval runtime? thunk)
   (let ((start (process-time-clock)))