time bug

[Matthew Fluet]

I got that time bug again.  I've given up on stracing self-compiles
(the compiler get < 50% of the CPU time and it's just not worth it).
Anyways, here's the Failure message:

mlton: traceBatch: t' - t::-: t1 = 597.600 t2 = 598.590

And here's all the relevant code; I don't see anything wrong -- anyone
else see something?

*** src/mlton/control/control.sml; structure Control

fun time () =
   let
      open Time
      val {children, self, gc, ...} = times ()
      fun add {utime, stime} = utime + stime
   in
      (add self + add children, add gc)
   end

local
  fun make(oper, oper_name)
    = fn (t1,t2,s)
       => oper(t1, t2)
          handle Time => Error.bug (s ^ "::" ^
				    oper_name ^
				    ": t1 = " ^
				    (Time.toString t1) ^
				    " t2 = " ^
				    (Time.toString t2))
in
  val timeMinus = make (Time.-, "-")
  val timePlus = make (Time.+, "+")
end

val ('a, 'b) traceBatch: string -> ('a -> 'b) ->
   (('a -> 'b) * (unit -> unit)) =
   fn name =>
   fn f => let
	      val total = ref Time.zero
	      val totalGC = ref Time.zero
	      val verb = Pass
	   in
	      (fn a =>
	       if Verbosity.<= (verb, !verbosity)
		  then let
			  val (t, gc) = time ()
			  fun done () =
			     let
				val (t', gc') = time ()
			     in
			       total :=
			       timePlus (!total,
					timeMinus (t',t,
						  "traceBatch: t' - t"),
					"traceBatch: !total");
			       totalGC :=
			       timePlus (!totalGC,
					timeMinus (gc',gc,
						  "traceBatch: gc' - gc"),
					"traceBatch: !totalGC")
			     end
		       in
			  (f a
			   before done ())
			  handle e => (messageStr (verb,
						   concat [name, " raised"])
				       ; raise e)
		       end
	       else f a,
		  fn () => messageStr (verb,
				       concat [name,
					       " totals ",
					       timeToString {total = !total,
							     gc = !totalGC}]))
	   end

***** lib/mlton/basic/time.sml ; structure Time

open Time

fun times (): times =
   let
     val {self, children, gc} = MLton.Rusage.rusage ()
     fun doit ({utime, stime, ...} : MLton.Rusage.t)
       = {utime = utime, stime = stime}
   in
     {self = doit self,
      children = doit children,
      gc = doit gc}
   end


***** basis-library/mlton/rusage.sml ; structure MLton.Rusage

structure Rusage =
   struct
      open Primitive.MLton.Rusage

      type t = {utime: Time.time, stime: Time.time}

      fun toTime {sec, usec} =
	 let
	   val time_sec = Time.fromSeconds (LargeInt.fromInt sec)
	   val time_usec = Time.fromMicroseconds (LargeInt.fromInt usec)
	 in
	   Time.+ (time_sec, time_usec)
	 end

      fun rusage () =
         let val _ = ru ()
	 in {self = {utime = toTime {sec = self_utime_sec (),
				     usec = self_utime_usec ()},
		     stime = toTime {sec = self_stime_sec (),
				     usec = self_stime_usec ()}},
	     children = {utime = toTime {sec = children_utime_sec (),
					 usec = children_utime_usec ()},
			 stime = toTime {sec = children_stime_sec (),
					 usec = children_stime_usec ()}},
	     gc = {utime = toTime {sec = gc_utime_sec (),
				   usec = gc_utime_usec ()},
		   stime = toTime {sec = gc_stime_sec (),
				   usec = gc_stime_usec ()}}}
	 end
   end

***** basis-library/system/Time.sml ; structure Time

      datatype time = T of {sec: Int.int, usec: Int.int}

      val million: int = 1000000

      fun convert (s: LargeInt.int): int =
	 LargeInt.toInt s handle Overflow => raise Time

      fun fromSeconds (s: LargeInt.int): time =
	 let val s = convert s
	 in if Primitive.safe andalso s < 0
	       then raise Time
	    else T {sec = s, usec = 0}
	 end

      fun fromMicroseconds (s: LargeInt.int): time =
	 let val s = convert s
	 in if Primitive.safe andalso s < 0
	       then raise Time
	    else T {sec = Int.quot (s, million),
		   usec = Int.rem (s, million)}
	 end

      val add =
	 fn (T {sec = s, usec = u}, T {sec = s', usec = u'}) =>
	 let
	    val u'' = u + u'
	    val s'' = s + s'
	    val (s'', u'') =
	       if u'' >= million
		  then (s'' + 1, u'' - million)
	       else (s'', u'')
	 in T {sec = s'', usec = u''}
	 end

      val sub =
	 fn (t1 as T {sec = s, usec = u}, t2 as T {sec = s', usec = u'}) =>
	 let
	    val s'' = s - s'
	    val u'' = u - u'
	    val (s'', u'') =
	       if u'' < 0
		  then (s'' - 1, u'' + million)
	       else (s'', u'')
	 in
	    if s'' < 0
	       then raise Time
	    else T {sec = s'', usec = u''}
	 end

      val op + = add
      val op - = sub

***** basis-library/misc/primitive.sml ; structure Primitive.MLton.Rusage

	    structure Rusage =
               struct
		 val ru = _ffi "MLton_Rusage_ru": unit -> unit;
		 val self_utime_sec = _ffi "MLton_Rusage_self_utime_sec": unit -> int;
		 val self_utime_usec = _ffi "MLton_Rusage_self_utime_usec": unit -> int;
		 val self_stime_sec = _ffi "MLton_Rusage_self_stime_sec": unit -> int;
		 val self_stime_usec = _ffi "MLton_Rusage_self_stime_usec": unit -> int;
		 val children_utime_sec = _ffi "MLton_Rusage_children_utime_sec": unit -> int;
		 val children_utime_usec = _ffi "MLton_Rusage_children_utime_usec": unit -> int;
		 val children_stime_sec = _ffi "MLton_Rusage_children_stime_sec": unit -> int;
		 val children_stime_usec = _ffi "MLton_Rusage_children_stime_usec": unit -> int;
		 val gc_utime_sec = _ffi "MLton_Rusage_gc_utime_sec": unit -> int;
		 val gc_utime_usec = _ffi "MLton_Rusage_gc_utime_usec": unit -> int;
		 val gc_stime_sec = _ffi "MLton_Rusage_gc_stime_sec": unit -> int;
		 val gc_stime_usec = _ffi "MLton_Rusage_gc_stime_usec": unit -> int;
	       end

***** runtime/basis/MLton/rusage.c

#include <sys/resource.h>

#include "gc.h"
#include "mlton-basis.h"

extern struct GC_state gcState;

static struct rusage self;
static struct rusage children;
static struct rusage gc;

Int MLton_Rusage_self_utime_sec() {
  return self.ru_utime.tv_sec;
}

Int MLton_Rusage_self_utime_usec() {
  return self.ru_utime.tv_usec;
}

Int MLton_Rusage_self_stime_sec() {
  return self.ru_stime.tv_sec;
}

Int MLton_Rusage_self_stime_usec() {
  return self.ru_stime.tv_usec;
}

Int MLton_Rusage_children_utime_sec() {
  return children.ru_utime.tv_sec;
}

Int MLton_Rusage_children_utime_usec() {
  return children.ru_utime.tv_usec;
}

Int MLton_Rusage_children_stime_sec() {
  return children.ru_stime.tv_sec;
}

Int MLton_Rusage_children_stime_usec() {
  return children.ru_stime.tv_usec;
}

Int MLton_Rusage_gc_utime_sec() {
  return gc.ru_utime.tv_sec;
}

Int MLton_Rusage_gc_utime_usec() {
  return gc.ru_utime.tv_usec;
}

Int MLton_Rusage_gc_stime_sec() {
  return gc.ru_stime.tv_sec;
}

Int MLton_Rusage_gc_stime_usec() {
  return gc.ru_stime.tv_usec;
}

void MLton_Rusage_ru() {
  gc = gcState.ru_gc;
  getrusage(RUSAGE_SELF, &self);
  getrusage(RUSAGE_CHILDREN, &children);
}