[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