1structure Profile :> Profile =
2struct
3
4open Binarymap
5
6type time = Time.time
7type call_info = {real: time, gc: time, sys: time, usr: time, n: int}
8
9val ptable = ref (Binarymap.mkDict String.compare : (string, call_info) dict)
10
11datatype 'a result = OK of 'a | Ex of exn
12
13fun return (OK x) = x | return (Ex e) = raise e
14
15fun time f x =
16   let
17      val timer2 = Timer.startRealTimer()
18      val timer = Timer.startCPUTimer()
19
20      val result = OK (f x) handle e => Ex e
21
22      val timetaken = Timer.checkCPUTimes timer
23      val timetaken2 = Timer.checkRealTimer timer2
24   in
25      (result, (timetaken, timetaken2))
26   end
27
28type timedata = {nongc: {usr: Time.time, sys: Time.time},
29                 gc: {usr: Time.time, sys: Time.time}}
30
31fun add_profile nm timefx =
32   case peek (!ptable, nm) of
33      NONE =>
34         let
35            val ({nongc, gc}: timedata, real) = timefx
36            val data =
37               {usr = #usr nongc,
38                sys = #sys nongc,
39                gc = Time.+ (#usr gc, #sys gc),
40                n = 1,
41                real = real}
42         in
43            ptable := insert (!ptable, nm, data)
44         end
45    | SOME {usr = usr0, sys = sys0, gc = gc0, n = n0, real = real0} =>
46         let
47            val ({nongc, gc}: timedata, real1) = timefx
48            open Time
49            val data =
50               {usr = usr0 + #usr nongc,
51                sys = sys0 + #sys nongc,
52                gc = gc0 + #usr gc + #sys gc,
53                n = Int.+ (n0, 1),
54                real = real0 + real1}
55         in
56            ptable := insert (!ptable, nm, data)
57         end
58
59fun profile_exn_opt do_exn do_ok do_both nm f x =
60  let
61     val (result, timefx) = time f x
62     val _ = if do_both then add_profile nm timefx else ()
63     val _ = case result of
64                OK _ => if do_ok then add_profile (nm ^ "_OK") timefx else ()
65              | Ex e =>
66                  (case do_exn of
67                      NONE => ()
68                    | SOME false => add_profile (nm ^ "_exn") timefx
69                    | SOME true => add_profile (nm ^ "_" ^ exnName e) timefx)
70  in
71     return result
72  end
73
74fun profile nm = profile_exn_opt NONE false true nm
75fun profile_with_exn nm = profile_exn_opt (SOME false) true true nm
76fun profile_with_exn_name nm = profile_exn_opt (SOME true) true true nm
77fun profile_no_exn nm = profile_exn_opt NONE true false nm
78
79fun reset1 nm =
80   ptable := #1 (remove (!ptable, nm)) handle Binarymap.NotFound => ()
81
82fun reset_all () = ptable := Binarymap.mkDict String.compare
83
84fun results () = Listsort.sort (fn (i1, i2) => String.compare (#1 i1, #1 i2))
85                               (listItems (!ptable))
86
87fun foldl_map _ (acc, []) = (acc, [])
88  | foldl_map f (acc, x :: xs) =
89      let
90         val (acc', y) = f (acc, x)
91         val (acc'', ys) = foldl_map f (acc', xs)
92      in
93         (acc'', y :: ys)
94      end
95
96fun output_profile_results outstr results =
97   let
98      fun foldl_map_this
99             ((nm_width, real_width, usr_width, sys_width, gc_width, n_width),
100             (nm, {usr, sys, gc, real, n})) =
101       let
102          val usr = Time.toString usr
103          val sys = Time.toString sys
104          val gc = Time.toString gc
105          val real = Time.toString real
106          val n = Int.toString n
107          fun max (i, s) = Int.max (i, String.size s)
108       in
109          ((max (nm_width, nm),
110            max (real_width, real),
111            max (usr_width, usr),
112            max (sys_width, sys),
113            max (gc_width, gc),
114            max (n_width, n)),
115           (nm, real, usr, sys, gc, n))
116       end
117
118      val ((nm_width, real_width, usr_width, sys_width, gc_width, n_width),
119           strings) =
120         foldl_map foldl_map_this ((25, 8, 8, 8, 8, 7), results)
121
122      fun print s = TextIO.output (outstr, s)
123
124      fun app_this (nm, real, usr, sys, gc, n) =
125         (print (StringCvt.padRight #" " nm_width nm)
126          ; print " "
127          ; print (StringCvt.padLeft #" " n_width n)
128          ; print " "
129          ; print (StringCvt.padLeft #" " real_width real)
130          ; print " "
131          ; print (StringCvt.padLeft #" " usr_width usr)
132          ; print " "
133          ; print (StringCvt.padLeft #" " sys_width sys)
134          ; print " "
135          ; print (StringCvt.padLeft #" " gc_width gc)
136          ; print "\n")
137   in
138      List.app app_this
139         (("Label", "real", "user", "system", "gc", "#calls") :: strings)
140   end
141
142fun output_profile_result outstr result = output_profile_results outstr [result]
143
144val print_profile_result = output_profile_result TextIO.stdOut
145
146val print_profile_results = output_profile_results TextIO.stdOut
147
148end
149