mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Merge pull request #4849 from unisonweb/fix/jit-time
Fix some inconsistencies in the time functions in the jit
This commit is contained in:
commit
a571042154
@ -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))
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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-"))
|
||||
|
Loading…
Reference in New Issue
Block a user