CVS: sml-dist/src/tools/TraceDebugProf back-trace.cm,NONE,1.1 back-trace.sml,NONE,1.1 coverage.cm,NONE,1.1 coverage.sml,NONE,1.1 install-back-trace.sml,NONE,1.1 install-coverage.sml,NONE,1.1 plugins.cm,NONE,1.1

Update of /cvsroot/smlnj/sml-dist/src/tools/TraceDebugProf
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28211/src/tools/TraceDebugProf

Added Files:
	back-trace.cm back-trace.sml coverage.cm coverage.sml 
	install-back-trace.sml install-coverage.sml plugins.cm 
Log Message:
moved TraceDebugProf where it belongs

--- NEW FILE: back-trace.cm ---
(* back-trace.cm
 *
 *   Library that (when loaded via CM.make) causes the test back-trace
 *   plugin to be installed into its core hook.
 *
 * Copyright (c) 2004 by The Fellowship of SML/NJ
 *
 * Author: Matthias Blume ([email protected])
 *)
Library
	structure BackTrace
	structure InstallBackTrace
is
	$smlnj-tdp/plugins.cm
	install-back-trace.sml

--- NEW FILE: back-trace.sml ---
(* back-trace.sml
 *
 *   A plug-in module for back-tracing.  This module hooks itself into
 *   the core environment so that tdp-instrumented code will invoke the
 *   provided functions "enter", "push", "save", and "report".
 *
 *   This module keeps track of the dynamic call-chain of instrumented modules.
 *   Non-tail calls are maintained in a stack-like fashion, and in addition
 *   to this the module will also track tail-calls so that a sequence of
 *   GOTO-like jumps from loop-cluster to loop-cluster can be shown.
 *
 *   This strategy, while certainly costly, has no more than constant-factor
 *   overhead in space and time and will keep tail-recursive code
 *   tail-recursive.
 *
 * Copyright (c) 2004 by The Fellowship of SML/NJ
 *
 * Author: Matthias Blume ([email protected])
 *)
structure BackTrace : sig
    val trigger : unit -> 'a
    val monitor : (unit -> 'a) -> 'a
    val install : unit -> unit
end = struct

    structure M = IntRedBlackMap

    (* Home-cooked set representation:
     *  This relies on two things:
     *   - we don't need a lookup operation
     *   - we only join sets that are known to be disjoint *)
    datatype set =
	EMPTY
      | SINGLETON of int
      | UNION of set * set

    fun fold f i EMPTY = i
      | fold f i (SINGLETON x) = f (x, i)
      | fold f i (UNION (x, y)) = fold f (fold f i y) x

    datatype descr =
	STEP of int
      | LOOP of set

    type stage = { num: int, from: int, descr: descr }

    type frame = { depth: int, map: int M.map, stages: stage list }

    type history = frame * frame list

    datatype state =
	NORMAL of history
      | PENDING of int * history

    val cur : state ref =
	ref (NORMAL ({ depth = 0, map = M.empty, stages = [] }, []))

    val names = ref (M.empty: string M.map)

    fun register (module, _: int, id, s) =
	names := M.insert (!names, module + id, s)

    fun enter (module, fct) = let
	val i = module + fct
	val (from, front, back) =
	    case !cur of
		PENDING (from, (front, back)) => (from, front, back)
	      | NORMAL (front, back) => (~1, front, back)
	val { depth, map, stages } = front
    in
	case M.find (map, i) of
	    SOME num => let
		fun toSet (STEP i) = SINGLETON i
		  | toSet (LOOP s) = s
		fun join (set, d) = UNION (set, toSet d)
		fun finish (stages, from, c, EMPTY) =
		    let val stage = { num = num, from = from,
				      descr = LOOP (toSet c) }
			val front' = { depth = depth,
				       map = map,
				       stages = stage :: stages }
		    in
			cur := NORMAL (front', back)
		    end
		  | finish (stages, from, c, set) =
		    let	val stage = { num = num, from = from,
				      descr = LOOP (join (set, c)) }
			fun ins (i, m) = M.insert (m, i, num)
			val front' = { depth = depth,
				       map = fold ins map set,
				       stages = stage :: stages }
		    in
			cur := NORMAL (front', back)
		    end
		fun loop ([], set) = () (* cannot happen! *)
		  | loop ({ num = n', from, descr = d' } :: t, set) =
		    if num = n' then finish (t, from, d', set)
		    else loop (t, join (set, d'))
	    in
		loop (stages, EMPTY)
	    end
	  | NONE => let
		val num = case stages of
			      [] => 0
			    | s0 :: _ => #num s0 + 1
		val stage = { num = num, from = from, descr = STEP i}
		val front' = { depth = depth,
			       map = M.insert (map, i, num),
			       stages = stage :: stages }
	    in
		cur := NORMAL (front' , back)
	    end
    end

    fun push (module, loc) = let
	val id = module + loc
	val (NORMAL old | PENDING (_, old)) = !cur
	val (front, _) = old
	val front' = { depth = #depth front + 1, map = M.empty, stages = [] }
    in
	cur := PENDING (id, (front', op :: old));
	fn () => cur := NORMAL old
    end

    fun nopush (module, loc) = let
	val id = module + loc
	val (NORMAL old | PENDING (_, old)) = !cur
    in
	cur := PENDING (id, old)
    end

    fun save () = let
	val old = !cur
    in
	fn () => cur := old
    end

    fun report () = let
	val (NORMAL top | PENDING (_, top)) = !cur
	val (front, back) = top
	fun do_report () = let
	    val (NORMAL bot | PENDING (_, bot)) = !cur
	    val (front', _) = bot
	    val bot_depth = #depth front'
	    fun isBot (f: frame) = #depth f = bot_depth
	    fun name (w, pad, from, i) = let
		fun find x = getOpt (M.find (!names, x), "???")
		val n = find i
		val tail = case from of
			       NONE => ["\n"]
			     | SOME j => ["\n          (from: ", find j, ")\n"]
	    in
		concat (w :: pad :: " " :: n :: tail)
	    end
	    fun stage (w, { num, from, descr = STEP i }, a) =
		name (w, "  ", SOME from, i) :: a
	      | stage (w, { num, from, descr = LOOP s }, a) = let
		    fun loop ([], a) = a
		      | loop ([i], a) = name (w, "-\\", SOME from, i) :: a
		      | loop (h :: t, a) =
			loop (t, name ("    ", " |", NONE, h) :: a)
		    fun start ([], a) = a
		      | start ([i], a) = name (w, "-(", SOME from, i) :: a
		      | start (h :: t, a) =
			loop (t, name ("    ", " /", NONE, h) :: a)
		in
		    start (fold (op ::) [] s, a)
		end
	    fun jumps ([], a) = a
	      | jumps ([n], a) = stage ("CALL", n, a)
	      | jumps (h :: t, a) = jumps (t, stage ("GOTO", h, a))
	    fun calls (h, [], a) = jumps (#stages h, a)
	      | calls (h, h' :: t, a) = let
		    val a = jumps (#stages h, a)
		in
		    if isBot h then a else calls (h', t, a)
		end
	in
	    rev (calls (front, back, []))
	end
    in
	do_report
    end

    exception BTraceTriggered of unit -> string list

    fun monitor work =
	let val restore = save ()
	    fun last (x, []) = x
	      | last (_, x :: xs) = last (x, xs)
	    fun emsg e =
		case SMLofNJ.exnHistory e of
		    [] => General.exnMessage e
		  | (h :: t) =>
		      concat [last (h, t), ": ", General.exnMessage e]
	    fun hdl (e, []) =
		  (Control.Print.say (emsg e ^ "\n\n");
		   raise e)
	      | hdl (e, hist) =
		  (Control.Print.say
		       (concat ("\n*** BACK-TRACE ***\n" :: hist));
		   Control.Print.say
		       (concat ["\n", emsg e, "\n\n"]);
		   raise e)
	in
	    work ()
	    handle e as BTraceTriggered do_report =>
		     (restore ();
		      hdl (e, do_report ()))
		 | e =>
		   let val do_report = report ()
		   in
		       restore ();
		       hdl (e, do_report ())
		   end
	end

    val name = "btrace"

    fun install () =
	let val plugin = { name = name, save = save,
			   push = push, nopush = nopush,
			   enter = enter, register = register }
	    val monitor = { name = name, monitor = monitor }
	    fun addto r x = r := x :: !r
	in
	    addto SMLofNJ.Internals.TDP.active_plugins plugin;
	    addto SMLofNJ.Internals.TDP.active_monitors monitor
	end

    fun trigger () = raise BTraceTriggered (report ())
end

--- NEW FILE: coverage.cm ---
(* coverage.cm
 *
 *   Library that (when loaded via CM.make) causes the test coverage
 *   plugin to be installed into its core hook.
 *
 * Copyright (c) 2004 by The Fellowship of SML/NJ
 *
 * Author: Matthias Blume ([email protected])
 *)
Library
	structure Coverage
	structure InstallCoverage
is
	$smlnj-tdp/plugins.cm
	install-coverage.sml

--- NEW FILE: coverage.sml ---
(* coverage.sml
 *
 *   Using the generic trace/debug/profile framework for test coverage.
 *
 * Copyright (c) 2004 by The Fellowship of SML/NJ
 *
 * Author: Matthias Blume ([email protected])
 *)
structure Coverage : sig

    type kind

    val functions:      kind
    val tail_calls:     kind
    val non_tail_calls: kind

    val not_covered : kind list -> unit
    val hot_spots : kind list -> int -> unit

    val install : unit -> unit
end = struct

    structure M = IntRedBlackMap
    structure F = FormatComb

    structure TDP = SMLofNJ.Internals.TDP

    type kind = int
    val functions = TDP.idk_entry_point
    val tail_calls = TDP.idk_tail_call
    val non_tail_calls = TDP.idk_non_tail_call

    type record = { kind : int, descr: string }

    val records = ref (M.empty : record M.map)

    val counters = ref (Array.fromList [0])

    fun count idx = Array.sub (!counters, idx) handle General.Subscript => 0

    fun bump (module, id) =
	let val idx = module + id
	    val a = !counters
	in
	    Array.update (a, idx, Array.sub (a, idx) + 1)
	    handle General.Subscript =>
		   let val olen = Array.length a
		       val nlen = Int.min (idx + 1, olen + olen)
		       fun cp i = if i < olen then Array.sub (a, i)
				  else if i = idx then 1
				  else 0
		   in
		       counters := Array.tabulate (nlen, cp)
		   end
	end

    val enter = bump
    fun push mi = (bump mi; fn () => ())
    val nopush = bump

    fun register (module, kind, id, s) =
	let val idx = module + id
	    val r = { kind = kind, descr = s }
	in
	    records := M.insert (!records, idx, r)
	end

    fun save () () = ()

    val name = "coverage"

    fun install () =
	let val plugin = { name = name, save = save,
			   push = push, nopush = nopush,
			   enter = enter, register = register }
	    fun addto r x = r := x :: !r
	in
	    addto TDP.active_plugins plugin
	end

    fun not_covered kinds =
	let fun zerocnt (idx, r: record) =
		count idx = 0 andalso List.exists (fn k => k = #kind r) kinds
	    val zrecords = M.filteri zerocnt (!records)
	    fun tell { descr, kind } =
		Control.Print.say (descr ^ "\n")
	in
	    M.app tell zrecords
	end

    fun hot_spots kinds n =
	let fun getcount (idx, r: record) =
		if List.exists (fn k => k = #kind r) kinds then
		    SOME (#descr r, count idx)
		else NONE
	    val countmap = M.mapPartiali getcount (!records)
	    val countlist = M.listItems countmap
	    fun lt ((_, c), (_, c')) = c < c'
	    val sortedcountlist = ListMergeSort.sort lt countlist
	    fun loop ([], _) = ()
	      | loop (_, 0) = ()
	      | loop ((descr, count) :: rest, n) =
		  (Control.Print.say (F.format (F.padl 3 F.int o F.sp 1 o F.string o F.nl) count descr);
		   loop (rest, n - 1))
	in
	    loop (sortedcountlist, n)
	end
end

--- NEW FILE: install-back-trace.sml ---
(* install-back-trace.sml
 *
 *   A module that causes (at link time) to have the back-trace
 *   plugin installed into its core hook.
 *
 * Copyright (c) 2004 by The Fellowship of SML/NJ
 *
 * Author: Matthias Blume ([email protected])
 *)
structure InstallBackTrace = struct
    val _ = BackTrace.install ()
end

--- NEW FILE: install-coverage.sml ---
(* install-coverage.sml
 *
 *   A module that causes (at link time) to have the test coverage
 *   plugin installed into its core hook.
 *
 * Copyright (c) 2004 by The Fellowship of SML/NJ
 *
 * Author: Matthias Blume ([email protected])
 *)
structure InstallCoverage = struct
    val _ = Coverage.install ()
end

--- NEW FILE: plugins.cm ---
(* plugins.cm
 *
 *   Library of plug-in modules for tracing, debugging, and profiling.
 *
 * Copyright (c) 2004 by The Fellowship of SML/NJ
 *
 * Author: Matthias Blume ([email protected])
 *)

Library
	structure BackTrace
	structure Coverage
is
	back-trace.sml
	coverage.sml

	$/basis.cm
	$/smlnj-lib.cm
	$smlnj/compiler.cm



-------------------------------------------------------
SF email is sponsored by - The IT Product Guide
Read honest & candid reviews on hundreds of IT Products from real users.
Discover which products truly live up to the hype. Start reading now.
http://ads.osdn.com/?ad_id=6595&alloc_id=14396&op=click