switch monotonic usage to CLOCK_MONOTONIC[_RAW]

crossfire/agent.rkt

@@ -27,10 +27,6 @@
 (define-logger agent #:parent global-logger)
 
 (define *max-cache-age* (* 3600 24 7))
-(define (current-seconds-utc)
-  (time-second (current-time 'time-utc)))
-(define (current-seconds-monotonic)
-  (time-second (current-time 'time-monotonic)))
 
 ;; global variables, yeet
 
@@ -78,7 +74,7 @@
     [(and (hash-has-key? cache-info file-hash/hex)
           (file-exists? tgz-file) (directory-exists? extract-dir))
      ;; do nothing, already exists. but update the cache-info
-     (hash-set! cache-info file-hash/hex (current-seconds-utc))
+     (hash-set! cache-info file-hash/hex (current-seconds))
      extract-dir]
     [else
      ;; just in case one existed but not the other
@@ -87,7 +83,7 @@
      ;; TODO this should be updated with the streaming interface
      (call-with-output-file tgz-file (lambda (out) (write-bytes (get-project-file tid) out)))
      (untgz tgz-file #:dest extract-dir)
-     (hash-set! cache-info file-hash/hex (current-seconds-utc))
+     (hash-set! cache-info file-hash/hex (current-seconds))
      extract-dir]))
 
 ;; updates the file cache by deleting expired stuff according to the given cache-info
@@ -181,6 +177,7 @@
   (log-agent-info "starting crossfire-agent v~a" (#%info-lookup 'version))
   (current-queue (make-async-channel))
 
+  ;; XXX : platform-specific behavior
   (define (get-config.linux-gnu)
     (call-with-input-file "/proc/self/exe"
       (lambda (in)

crossfire/server.rkt

@@ -114,19 +114,6 @@
 
 ;; utils
 
-;; time helpers (because time is a bigge heck)
-;; monotonic time can be different than wall clock time
-;; for our purposes, tasks have two measures of time associated with them:
-;;  - wall clock instant representing when the task was started
-;;  - duration of the task (as a difference of monotonic times)
-;; it's important never to mix up wall clock and monotonic measurements, and never to take a
-;; difference between two wall clock times
-;; fortunately, racket provides srfi/19 as part of the default installation which is very convenient
-(define (current-seconds-monotonic)
-  (time-second (current-time 'time-monotonic)))
-(define (current-seconds-utc)
-  (time-second (current-time 'time-utc)))
-
 (define (query/insert-id db stmt . args)
   (define info (simple-result-info (apply query db stmt args)))
   (cdr (assoc 'insert-id info)))
@@ -227,6 +214,7 @@
     (file->bytes
       (get-binary-path-for-arch agent-arch)))
 
+  ;; XXX : platform-specific behavior
   (define (configure.linux-gnu)
     (define trailing-data (s-exp->fasl (list agent-node server-node)))
     ;; write 32 bit unsigned big endian trailer size (including size)
@@ -524,7 +512,7 @@
       (cond
         [(false? assign-data) #f]
         [else
-         (define start-time-utc (current-seconds-utc))
+         (define start-time-utc (current-seconds))
          (define start-time-monotonic (current-seconds-monotonic))
          (define aid (make-assignment-id))
          (define mf-parsed (task-state-manifest ts))
@@ -557,7 +545,7 @@
                        success-input)
       (query-exec
         (current-db) q-add-task-match
-        (assignment-taskid assignment) id (current-seconds-utc) (s-exp->fasl success-input)))
+        (assignment-taskid assignment) id (current-seconds) (s-exp->fasl success-input)))
 
     (define (complete-assignment! assignment)
       (log-server-info "agent handler ~a: completed assignment for task ~a" id

crossfire/static-support.rkt

@@ -88,7 +88,15 @@
 (module+ misc-calls
   (require ffi/unsafe/port racket/match)
 
-  (provide port-fsync)
+  (provide port-fsync current-seconds-monotonic)
+
+  ;; XXX : platform-specific behavior
+
+  (define (get-libc/init)
+    (let ([libc (void)])
+      (when (void? libc)
+        (set! libc (ffi-lib/runtime "libc" '("6" "7"))))
+      libc))
 
   (define port-fsync/unix
     ;; lazy time
@@ -98,8 +106,7 @@
         (when (false? fd) (error "invalid port provided"))
         (when (false? fsync-call)
           (set! fsync-call
-            (get-ffi-obj/runtime
-              "fsync" (ffi-lib/runtime "libc" '("6" "7"))
+            (get-ffi-obj/runtime "fsync" (get-libc/init)
               (_fun #:save-errno 'posix _int -> (res : _int)
                     -> (unless (zero? res)
                          (raise (exn:fail:filesystem:errno (format "fsync: errno ~a" (saved-errno))
@@ -110,4 +117,44 @@
   (define (port-fsync port)
     (match (system-type 'os)
       ['unix (port-fsync/unix port)]
-      [x (error "don't know how to fsync on" x)])))
+      [x (error "don't know how to fsync on" x)]))
+
+
+  ;; time helpers (because time is a bigge heck)
+  ;; monotonic time can be different than wall clock time
+  ;; for our purposes, tasks have two measures of time associated with them:
+  ;;  - wall clock instant representing when the task was started
+  ;;  - duration of the task (as a difference of monotonic times)
+  ;; it's important never to mix up wall clock and monotonic measurements, and never to take a
+  ;; difference between two wall clock times
+
+  (define current-seconds-monotonic/unix
+    (let ([clock-gettime-call #f]
+          [call-param #f])
+      ;; XXX : assumes time_t is long, which idk is probably a fair assumption but it could bork
+      ;; things, for example on big-endian systems with 64 bit time_t and 32-bit long
+      ;;; (these might not actually exist)
+      (define-cstruct _timespec ([tv-sec _long] [tv-nsec _long]))
+      (define *CLOCK-MONOTONIC* 1)
+      (define *CLOCK-MONOTONIC-RAW* 4)
+      (lambda ()
+        (when (false? clock-gettime-call)
+          (set! clock-gettime-call
+            (get-ffi-obj/runtime "clock_gettime" (get-libc/init)
+              (_fun #:save-errno 'posix _int (out : _timespec-pointer = (make-timespec 0 0))
+                    -> (res : _int)
+                    -> (if (zero? res)
+                         (timespec-tv-sec out)
+                         (raise (exn:fail (format "clock-gettime: errno ~a" (saved-errno))
+                                          (current-continuation-marks)))))))
+          ;; attempt with linux-specific parameter
+          ;; if it fails, fall back to POSIX
+          (with-handlers ([exn:fail? (lambda (_) (set! call-param *CLOCK-MONOTONIC*))])
+            (clock-gettime-call *CLOCK-MONOTONIC-RAW*)
+            (set! call-param *CLOCK-MONOTONIC-RAW*)))
+        (clock-gettime-call call-param))))
+
+  (define (current-seconds-monotonic)
+    (match (system-type 'os)
+      ['unix (current-seconds-monotonic/unix)]
+      [x (error "don't know how to current-seconds-monotonic on" x)])))