[MLton-devel] cvs commit: Implemented Time.time as a LargeInt.
Stephen Weeks
sweeks@users.sourceforge.net
Thu, 11 Sep 2003 08:12:29 -0700
sweeks 03/09/11 08:12:29
Modified: basis-library/mlton itimer.sml
basis-library/system time.sig time.sml
doc changelog
regression time.sml
Log:
Revision Changes Path
1.8 +8 -3 mlton/basis-library/mlton/itimer.sml
Index: itimer.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/itimer.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- itimer.sml 3 Jan 2003 06:14:13 -0000 1.7
+++ itimer.sml 11 Sep 2003 15:12:28 -0000 1.8
@@ -14,9 +14,14 @@
| Real => Prim.real
| Virtual => Prim.virtual
- fun set' (t, {interval = Time.T {sec = s1, usec = u1},
- value = Time.T {sec = s2, usec = u2}}) =
- Prim.set (toInt t, s1, u1, s2, u2)
+ fun set' (t, {interval, value}) =
+ let
+ fun split t = IntInf.quotRem (Time.toMicroseconds t, 1000000)
+ val (s1, u1) = split interval
+ val (s2, u2) = split value
+ in
+ Prim.set (toInt t, s1, u1, s2, u2)
+ end
fun set (z as (t, _)) =
if Primitive.MLton.Profile.isOn
1.3 +0 -8 mlton/basis-library/system/time.sig
Index: time.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/time.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- time.sig 24 Nov 2002 01:19:40 -0000 1.2
+++ time.sig 11 Sep 2003 15:12:29 -0000 1.3
@@ -25,11 +25,3 @@
val fromString: string -> time option
val scan: (char, 'a) StringCvt.reader -> (time, 'a) StringCvt.reader
end
-
-signature TIME_EXTRA =
- sig
- include TIME
-
- datatype time' = T of {sec: Int.int, usec: Int.int}
- sharing type time = time'
- end
1.9 +133 -183 mlton/basis-library/system/time.sml
Index: time.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/time.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- time.sml 10 Sep 2003 01:38:33 -0000 1.8
+++ time.sml 11 Sep 2003 15:12:29 -0000 1.9
@@ -5,196 +5,146 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-structure Time: TIME_EXTRA =
- struct
- structure Prim = Primitive.Time
-
- (* Inv: 0 <= usec < 1000000 *)
- datatype time = T of {sec: Int.int,
- usec: Int.int}
- datatype time' = datatype time
-
- exception Time
- val thousand'': IntInf.int = 1000
- val thousand': LargeInt.int = 1000
- val thousand: int = 1000
- val million'': IntInf.int = 1000000
- val million': LargeInt.int = 1000000
- val million: int = 1000000
-
- val zeroTime = T {sec = 0,
- usec = 0}
-
- fun fromReal (r: LargeReal.real): time =
- let
- val sec = LargeReal.floor r
- val usec = LargeReal.floor (1E6 * (r - (LargeReal.fromInt sec)))
- in T {sec = sec, usec = usec}
- end handle Overflow => raise Time
-
- fun toReal (T {sec, usec}): LargeReal.real =
- LargeReal.fromInt sec + (LargeReal.fromInt usec / 1E6)
-
- fun toSeconds (T {sec, ...}) =
- LargeInt.fromInt sec
-
- fun toMilliseconds (T {sec, usec}): LargeInt.int =
- thousand' * LargeInt.fromInt sec
- + LargeInt.fromInt (Int.quot (usec, thousand))
-
- fun toMicroseconds (T {sec, usec}): LargeInt.int =
- million' * LargeInt.fromInt sec + LargeInt.fromInt usec
-
- fun convert (s: LargeInt.int): int =
- LargeInt.toInt s handle Overflow => raise Time
-
- fun fromSeconds (s: LargeInt.int): time =
- T {sec = convert s, usec = 0}
-
- fun fromMilliseconds (msec: LargeInt.int): time =
- let
- val msec = IntInf.fromLarge msec
- val (sec, msec) = IntInf.quotRem (msec, thousand'')
- val (sec, msec) = (IntInf.toLarge sec, IntInf.toLarge msec)
- in
- T {sec = convert sec,
- usec = (LargeInt.toInt msec) * thousand}
- end
-
- fun fromMicroseconds (usec: LargeInt.int): time =
- let
- val usec = IntInf.fromLarge usec
- val (sec, usec) = IntInf.quotRem (usec, million'')
- val (sec, usec) = (IntInf.toLarge sec, IntInf.toLarge usec)
- in
- T {sec = convert sec,
- usec = LargeInt.toInt usec}
- end
-
- val add =
- fn (T {sec = s, usec = u}, T {sec = s', usec = u'}) =>
- let
- val s'' = s + s' (* overflow possible *)
- val u'' = u +? u'
- val (s'', u'') =
- if u'' >= million
- then (s'' + 1, (* overflow possible *)
- u'' -? million)
- else (s'', u'')
- in T {sec = s'', usec = u''}
- end
- handle Overflow => raise Time
+structure Time: TIME =
+struct
- val sub =
- fn (T {sec = s, usec = u}, T {sec = s', usec = u'}) =>
- let
- val s'' = s - s' (* overflow possible *)
- val u'' = u -? u'
- val (s'', u'') =
- if u'' < 0
- then (s'' - 1, (* overflow possible *)
- u'' +? million)
- else (s'', u'')
- in T {sec = s'', usec = u''}
- end
- handle Overflow => raise Time
+structure Prim = Primitive.Time
+
+(* A time is represented as a number of microseconds. *)
+val precision: int = 6
+val ticksPerSec: LargeInt.int = 1000000
+
+datatype time = T of LargeInt.int
+
+exception Time
+
+val zeroTime = T 0
+
+fun fromReal r =
+ T (Real.toLargeInt IEEEReal.TO_NEAREST (r * Real.fromLargeInt ticksPerSec))
- fun compare (T {sec = s, usec = u}, T {sec = s', usec = u'}) =
- if s > s'
- then GREATER
- else if s = s'
- then Int.compare (u, u')
- else (* s < s' *) LESS
-
- (* There's a mess here to work around a bug in vmware virtual machines
- * that may return a decreasing(!) sequence of time values. This will
- * cause some programs to raise Time exceptions where it should be
- * impossible.
- *)
- local
- fun getNow (): time =
- (Prim.gettimeofday ()
- ; T {sec = Prim.sec (), usec = Prim.usec ()})
- val prev = ref (getNow ())
+fun toReal (T i) =
+ Real.fromLargeInt i / Real.fromLargeInt ticksPerSec
+
+local
+ fun make ticksPer =
+ let
+ val d = ticksPerSec div ticksPer
+ in
+ (fn i => T (i * d), fn T i => LargeInt.quot (i, d))
+ end
+in
+ val (fromSeconds, toSeconds) = make 1
+ val (fromMilliseconds, toMilliseconds) = make 1000
+ val (fromMicroseconds, toMicroseconds) = make 1000000
+end
+
+local
+ fun make f (T i, T i') = f (i, i')
+in
+ val compare = make LargeInt.compare
+ val op < = make LargeInt.<
+ val op <= = make LargeInt.<=
+ val op > = make LargeInt.>
+ val op >= = make LargeInt.>=
+end
+
+(* There's a mess here to work around a bug in vmware virtual machines
+ * that may return a decreasing(!) sequence of time values. This will
+ * cause some programs to raise Time exceptions where it should be
+ * impossible.
+ *)
+local
+ fun getNow (): time =
+ (Prim.gettimeofday ()
+ ; T (LargeInt.fromInt (Prim.sec ()) * ticksPerSec
+ + LargeInt.fromInt (Prim.usec ())))
+ val prev = ref (getNow ())
+in
+ fun now (): time =
+ let
+ val old = !prev
+ val t = getNow ()
in
- fun now (): time =
- let
- val old = !prev
- val t = getNow ()
- in
- case compare (old, t) of
- GREATER => old
- | _ => (prev := t; t)
- end
+ case compare (old, t) of
+ GREATER => old
+ | _ => (prev := t; t)
end
+end
- val fmt: int -> time -> string =
- fn n => (Real.fmt (StringCvt.FIX (SOME n))) o toReal
+val fmt: int -> time -> string =
+ fn n => (Real.fmt (StringCvt.FIX (SOME n))) o toReal
- val toString = fmt 3
+val toString = fmt 3
- (* Adapted from MLKitV3 basislib/Time.sml*)
- fun scan getc src =
+(* Adapted from MLKitV3 basislib/Time.sml*)
+fun scan getc src =
+ let
+ val charToDigit = StringCvt.charToDigit StringCvt.DEC
+ fun pow10 0 = 1
+ | pow10 n = 10 * pow10 (n-1)
+ fun mkTime sign intv fracv decs =
let
- val charToDigit = StringCvt.charToDigit StringCvt.DEC
- fun pow10 0 = 1
- | pow10 n = 10 * pow10 (n-1)
- fun mkTime sign intv fracv decs =
- let
- val sec = intv
- val usec = (pow10 (7-decs) * fracv + 5) div 10
- val t = T {sec = intv, usec = usec}
- in
- if sign then t else sub (zeroTime, t)
- end
- fun frac' sign intv fracv decs src =
- if decs >= 7
- then SOME (mkTime sign intv fracv decs,
- StringCvt.dropl Char.isDigit getc src)
- else case getc src of
- NONE => SOME (mkTime sign intv fracv decs, src)
- | SOME (c, rest) =>
- (case charToDigit c of
- NONE => SOME (mkTime sign intv fracv decs, src)
- | SOME d => frac' sign intv (10 * fracv + d) (decs + 1) rest)
- fun frac sign intv src =
- case getc src of
- NONE => NONE
- | SOME (c, rest) =>
- (case charToDigit c of
- NONE => NONE
- | SOME d => frac' sign intv d 1 rest)
- fun int' sign intv src =
- case getc src of
- NONE => SOME (mkTime sign intv 0 7, src)
- | SOME (#".", rest) => frac sign intv rest
- | SOME (c, rest) =>
- (case charToDigit c of
- NONE => SOME (mkTime sign intv 0 7, src)
- | SOME d => int' sign (10 * intv + d) rest)
- fun int sign src =
- case getc src of
- NONE => NONE
- | SOME (c, rest) =>
- (case charToDigit c of
- NONE => NONE
- | SOME d => int' sign d rest)
- in
- case getc (StringCvt.skipWS getc src) of
- NONE => NONE
- | SOME (#"+", rest) => int true rest
- | SOME (#"~", rest) => int false rest
- | SOME (#"-", rest) => int false rest
- | SOME (#".", rest) => frac true 0 rest
- | SOME (c, rest) =>
- (case charToDigit c of
- NONE => NONE
- | SOME d => int' true d rest)
+ val sec = intv
+ val usec = (pow10 (7-decs) * fracv + 5) div 10
+ val t = Int.toLarge intv * ticksPerSec + Int.toLarge usec
+ val t = if sign then t else ~ t
+ in
+ T t
end
- handle Overflow => raise Time
- val fromString = StringCvt.scanString scan
-
- val op + = add
- val op - = sub
- val {<, <=, >, >=} = Util.makeOrder compare
+ fun frac' sign intv fracv decs src =
+ if Int.>= (decs, 7)
+ then SOME (mkTime sign intv fracv decs,
+ StringCvt.dropl Char.isDigit getc src)
+ else case getc src of
+ NONE => SOME (mkTime sign intv fracv decs, src)
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => SOME (mkTime sign intv fracv decs, src)
+ | SOME d => frac' sign intv (10 * fracv + d) (decs + 1) rest)
+ fun frac sign intv src =
+ case getc src of
+ NONE => NONE
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => NONE
+ | SOME d => frac' sign intv d 1 rest)
+ fun int' sign intv src =
+ case getc src of
+ NONE => SOME (mkTime sign intv 0 7, src)
+ | SOME (#".", rest) => frac sign intv rest
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => SOME (mkTime sign intv 0 7, src)
+ | SOME d => int' sign (10 * intv + d) rest)
+ fun int sign src =
+ case getc src of
+ NONE => NONE
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => NONE
+ | SOME d => int' sign d rest)
+ in
+ case getc (StringCvt.skipWS getc src) of
+ NONE => NONE
+ | SOME (#"+", rest) => int true rest
+ | SOME (#"~", rest) => int false rest
+ | SOME (#"-", rest) => int false rest
+ | SOME (#".", rest) => frac true 0 rest
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => NONE
+ | SOME d => int' true d rest)
end
+handle Overflow => raise Time
+
+val fromString = StringCvt.scanString scan
+
+local
+ fun make f (T i, T i') = T (f (i, i'))
+in
+ val op + = make LargeInt.+
+ val op - = make LargeInt.-
+end
+
+end
1.77 +4 -1 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.76
retrieving revision 1.77
diff -u -r1.76 -r1.77
--- changelog 11 Sep 2003 14:29:36 -0000 1.76
+++ changelog 11 Sep 2003 15:12:29 -0000 1.77
@@ -1,7 +1,10 @@
Here are the changes since version 20030716.
* 2003-09-11
- - OS.IO.poll and Socket.select now raise errors on negative timeouts.
+ - OS.IO.poll and Socket.select now raise errors on negative
+ timeouts.
+ - Time.time is now implemented using IntInf instead of Int, which
+ means that a much larger range of time values is representable.
* 2003-09-10
- Word64 is now there.
1.5 +2 -2 mlton/regression/time.sml
Index: time.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/time.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- time.sml 10 Sep 2003 01:41:08 -0000 1.4
+++ time.sml 11 Sep 2003 15:12:29 -0000 1.5
@@ -56,8 +56,8 @@
andalso fromReal 10.25 = fromSeconds 10 + fromMilliseconds 250);
val test3b = tst0 "test3b" ((fromReal ~1.0 seq "OK")
handle _ => "WRONG")
-val test3c = tst0 "test3c" ((fromReal 1E300 seq "WRONG")
- handle Time => "OK" | _ => "WRONG")
+val test3c = tst0 "test3c" ((fromReal 1E300 seq "OK")
+ handle Time => "WRONG" | _ => "OK")
val test4a =
tst' "test4a" (fn _ => Real.==(toReal (fromReal 100.25), 100.25));
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel