Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /trace-debug-profile/trunk/coverage.sml
ViewVC logotype

Annotation of /trace-debug-profile/trunk/coverage.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2170 - (view) (download)

1 : mblume 1758 (* coverage.sml
2 :     *
3 :     * Using the generic trace/debug/profile framework for test coverage.
4 :     *
5 :     * Copyright (c) 2004 by The Fellowship of SML/NJ
6 :     *
7 :     * Author: Matthias Blume (blume@tti-c.org)
8 :     *)
9 :     structure Coverage : sig
10 :    
11 :     type kind
12 :    
13 :     val functions: kind
14 :     val tail_calls: kind
15 :     val non_tail_calls: kind
16 :    
17 :     val not_covered : kind list -> unit
18 :     val hot_spots : kind list -> int -> unit
19 :    
20 :     val install : unit -> unit
21 :     end = struct
22 :    
23 :     structure M = IntRedBlackMap
24 :     structure F = FormatComb
25 :    
26 :     structure TDP = SMLofNJ.Internals.TDP
27 :    
28 :     type kind = int
29 :     val functions = TDP.idk_entry_point
30 :     val tail_calls = TDP.idk_tail_call
31 :     val non_tail_calls = TDP.idk_non_tail_call
32 :    
33 :     type record = { kind : int, descr: string }
34 :    
35 :     val records = ref (M.empty : record M.map)
36 :    
37 :     val counters = ref (Array.fromList [0])
38 :    
39 :     fun count idx = Array.sub (!counters, idx) handle General.Subscript => 0
40 :    
41 :     fun bump (module, id) =
42 :     let val idx = module + id
43 :     val a = !counters
44 :     in
45 :     Array.update (a, idx, Array.sub (a, idx) + 1)
46 :     handle General.Subscript =>
47 :     let val olen = Array.length a
48 :     val nlen = Int.min (idx + 1, olen + olen)
49 :     fun cp i = if i < olen then Array.sub (a, i)
50 :     else if i = idx then 1
51 :     else 0
52 :     in
53 :     counters := Array.tabulate (nlen, cp)
54 :     end
55 :     end
56 :    
57 :     val enter = bump
58 :     fun push mi = (bump mi; fn () => ())
59 :     val nopush = bump
60 :    
61 :     fun register (module, kind, id, s) =
62 :     let val idx = module + id
63 :     val r = { kind = kind, descr = s }
64 :     in
65 :     records := M.insert (!records, idx, r)
66 :     end
67 :    
68 :     fun save () () = ()
69 :    
70 :     val name = "coverage"
71 :    
72 :     fun install () =
73 :     let val plugin = { name = name, save = save,
74 :     push = push, nopush = nopush,
75 :     enter = enter, register = register }
76 :     fun addto r x = r := x :: !r
77 :     in
78 :     addto TDP.active_plugins plugin
79 :     end
80 :    
81 :     fun not_covered kinds =
82 :     let fun zerocnt (idx, r: record) =
83 :     count idx = 0 andalso List.exists (fn k => k = #kind r) kinds
84 :     val zrecords = M.filteri zerocnt (!records)
85 :     fun tell { descr, kind } =
86 :     Control.Print.say (descr ^ "\n")
87 :     in
88 :     M.app tell zrecords
89 :     end
90 :    
91 :     fun hot_spots kinds n =
92 :     let fun getcount (idx, r: record) =
93 :     if List.exists (fn k => k = #kind r) kinds then
94 :     SOME (#descr r, count idx)
95 :     else NONE
96 :     val countmap = M.mapPartiali getcount (!records)
97 :     val countlist = M.listItems countmap
98 :     fun lt ((_, c), (_, c')) = c < c'
99 :     val sortedcountlist = ListMergeSort.sort lt countlist
100 :     fun loop ([], _) = ()
101 :     | loop (_, 0) = ()
102 :     | loop ((descr, count) :: rest, n) =
103 :     (Control.Print.say (F.format (F.padl 3 F.int o F.sp 1 o F.string o F.nl) count descr);
104 :     loop (rest, n - 1))
105 :     in
106 :     loop (sortedcountlist, n)
107 :     end
108 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0