profiling

[Stephen Weeks]

> > Actually, equals and current could be implemented at SML level if the
> > basis library put a wrapper around the raw profile array and were
> > responsible for the initialization and writing at exit of the
> > "mlmon.out" main profile array.  I have no problems with that.
> 
> I don't understand the last paragraph.

Hopefully the following code clarifies what I had in mind.

--------------------------------------------------------------------------------

signature MLTON_PROFILE =
   sig
      val profile: bool

      structure Data:
	 sig
	    type t

	    val equals: t * t -> bool
	    val free: t -> unit
	    val malloc: unit -> t
	    val reset: t -> unit
	    val write: t * string -> unit
	 end
      
      val current: unit -> Data.t
      val setCurrent: Data.t -> unit
   end

functor MLtonProfile
   (structure Cleaner:
       sig
	  type t

	  val addNew: t * (unit -> unit) -> unit
	  val atExit: t
       end
    structure Profile:
       sig
	  val profile: bool
	     
	  structure Data:
	     sig
		type t (* = pointer *)

		val free: t -> unit
		val malloc: unit -> t
		val reset: t -> unit
		val write: t * string -> unit
	     end
	  val setCurrent: Data.t -> unit
       end): MLTON_PROFILE =
struct

val profile = Profile.profile
   
structure Data =
   struct
      datatype t = T of {array: Profile.Data.t,
			 isFreed: bool ref}

      val all: t list ref = ref []
	 
      local
	 fun make f (T r) = f r
      in
	 val array = make #array
	 val isFreed = make #isFreed
      end

      fun equals (d, d') = isFreed d = isFreed d'

      fun free (d as T {array, isFreed, ...}) =
	 if !isFreed
	    then raise Fail "duplicate free"
	 else
	    (all := List.filter (fn d' => not (equals (d, d'))) (!all)
	     ; Profile.Data.free array
	     ; isFreed := true)

      fun malloc () =
	 let
	    val d = T {array = Profile.Data.malloc (),
		       isFreed = ref false}
	    val _ = all := d :: !all
	 in
	    d
	 end

      fun reset (T {array, isFreed, ...}) =
	 if !isFreed
	    then raise Fail "reset of freed data"
	 else Profile.Data.reset array

      fun write (T {array, isFreed, ...}, file) =
	 if !isFreed
	    then raise Fail "write of freed data"
	 else Profile.Data.write (array, file)
   end

val d = Data.malloc ()
val r = ref d

fun current () = !r
  
fun setCurrent (d as Data.T {array, isFreed, ...}) =
   if !isFreed
      then raise Fail "setCurrent of freed data"
   else (r := d
	 ; Profile.setCurrent array)

val _ = setCurrent d

val _ = Cleaner.addNew (Cleaner.atExit, fn () =>
			let
			   val d = current ()
			   val _ = Data.write (d, "mlmon.out")
			   val _ = Data.free d
			in
			   case !Data.all of
			      [] => ()
			    | _ => raise Fail "unfreed data at program exit"
			end)

end