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