mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-26 02:55:19 +03:00
Fix some inconsistencies in the time functions in the jit
Some racket functions return integers and others floating point, so some care is needed to make sure they work. This adds a designated internal unison time rep as well instead of just using the raw value returned by the racket function.
This commit is contained in:
parent
049b223005
commit
13ded7d15e
@ -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