Merge pull request #4849 from unisonweb/fix/jit-time

Fix some inconsistencies in the time functions in the jit

scheme-libs/racket/unison/core.ss

@@ -407,6 +407,11 @@
     (compare-termlink lnl lnr)
     (lexico-compare envl envr cmp-ty)))
 
+(define (compare-timespec l r)
+  (comparisons
+    (compare-num (unison-timespec-sec l) (unison-timespec-sec r))
+    (compare-num (unison-timespec-nsec l) (unison-timespec-nsec r))))
+
 (define (universal-compare l r [cmp-ty #f])
   (define (u-proc? v)
     (or (procedure? v) (unison-closure? v)))
@@ -429,6 +434,8 @@
      (compare-termlink l r)]
     [(and (unison-typelink? l) (unison-typelink? r))
      (compare-typelink l r)]
+    [(and (unison-timespec? l) (unison-timespec? r))
+     (compare-timespec l r)]
     [(= 3 (value->category l) (value->category r))
      (compare-typelink (pseudo-data-link l) (pseudo-data-link r))]
     [(= (value->category l) (value->category r))

scheme-libs/racket/unison/data.ss

@@ -25,6 +25,7 @@
   (struct-out unison-typelink-derived)
   (struct-out unison-code)
   (struct-out unison-quote)
+  (struct-out unison-timespec)
 
   define-builtin-link
   declare-builtin-link
@@ -253,6 +254,26 @@
      (apply (unison-closure-code clo)
             (append (unison-closure-env clo) rest))]))
 
+(struct unison-timespec (sec nsec)
+  #:transparent
+  #:property prop:equal+hash
+  (let ()
+    (define (equal-proc tml tmr rec)
+      (match tml
+        [(unison-timespec sl nsl)
+         (match tmr
+           [(unison-timespec sr nsr)
+            (and (= sl sr) (= nsl nsr))])]))
+
+    (define ((hash-proc init) tm rec)
+      (match tm
+        [(unison-timespec s ns)
+         (fxxor (fx*/wraparound (rec s) 67)
+                (fx*/wraparound (rec ns) 71)
+                (fx*/wraparound init 73))]))
+
+    (list equal-proc (hash-proc 3) (hash-proc 5))))
+
 (define-syntax (define-builtin-link stx)
   (syntax-case stx ()
     [(_ name)

scheme-libs/racket/unison/io.rkt

@@ -118,17 +118,38 @@
     (ref-either-right (inexact->exact (* 1000 (current-inexact-milliseconds)))))
 
 (define (threadCPUTime.v1)
-    (right (current-process-milliseconds (current-thread))))
+  (right
+    (integer->time
+      (current-process-milliseconds (current-thread)))))
+
 (define (processCPUTime.v1)
-    (right (current-process-milliseconds 'process)))
+  (right
+    (integer->time
+      (current-process-milliseconds #f))))
+
 (define (realtime.v1)
-    (right (current-inexact-milliseconds)))
+  (right
+    (float->time
+      (current-inexact-milliseconds))))
+
 (define (monotonic.v1)
-    (right (current-inexact-monotonic-milliseconds)))
+  (right
+    (float->time
+      (current-inexact-monotonic-milliseconds))))
+
+(define (integer->time msecs)
+  (unison-timespec
+    (truncate (/ msecs 1000))
+    (* (modulo msecs 1000) 1000000)))
+
+(define (float->time msecs)
+  (unison-timespec
+    (trunc (/ msecs 1000))
+    (trunc (* (flmod msecs 1000.0) 1000000))))
 
 ;
-(define (flt f) (fl->exact-integer (fltruncate f)))
+(define (trunc f) (inexact->exact (truncate f)))
 
-(define (sec.v1 ts) (flt (/ ts 1000)))
+(define sec.v1 unison-timespec-sec)
 
-(define (nsec.v1 ts) (flt (* (flmod ts 1000.0) 1000000)))
+(define nsec.v1 unison-timespec-nsec)

unison-src/builtin-tests/io-tests.u

@@ -20,6 +20,9 @@ io.tests = Tests.main do
     !io.test_isFileOpen
     !io.test_ready
     !io.test_now
+    !io.test_monotonic
+    !io.test_processCPUTime
+    !io.test_threadCPUTime
     !io.test_isSeekable
     !io.test_handlePosition
     !io.test_renameDirectory
@@ -79,6 +82,29 @@ io.test_now = do
             else
                 Tests.fail "!now" "now is too small"
 
+io.test_threadCPUTime = do
+  match !threadCPUTime with
+    Duration s ns
+      | (s == +0) && (ns == 0) ->
+        Tests.pass "!threadCPUTime"
+      | otherwise ->
+        Tests.pass "!threadCPUTime"
+
+io.test_processCPUTime = do
+  match !processCPUTime with
+    Duration s ns
+      | (s == +0) && (ns == 0) ->
+        Tests.pass "!processCPUTime"
+      | otherwise ->
+        Tests.pass "!processCPUTime"
+
+io.test_monotonic = do
+  match !Clock.monotonic with
+    Duration s ns
+      | (s == +0) && (ns == 0) ->
+        Tests.pass "!Clock.monotonic"
+      | otherwise ->
+        Tests.pass "!Clock.monotonic"
 
 io.test_createTempDirectory = do
     tmp = (createTempDirectory (FilePath "prefix-"))