Annotation of /trace-debug-profile/releases/release-110.74/back-trace.sml

Parent Directory | Revision Log

---

Revision 3692 - (view) (download)

1 :	mblume	1758	(* back-trace.sml
2 :			*
3 :			* A plug-in module for back-tracing. This module hooks itself into
4 :			* the core environment so that tdp-instrumented code will invoke the
5 :			* provided functions "enter", "push", "save", and "report".
6 :			*
7 :			* This module keeps track of the dynamic call-chain of instrumented modules.
8 :			* Non-tail calls are maintained in a stack-like fashion, and in addition
9 :			* to this the module will also track tail-calls so that a sequence of
10 :			* GOTO-like jumps from loop-cluster to loop-cluster can be shown.
11 :			*
12 :			* This strategy, while certainly costly, has no more than constant-factor
13 :			* overhead in space and time and will keep tail-recursive code
14 :			* tail-recursive.
15 :			*
16 :			* Copyright (c) 2004 by The Fellowship of SML/NJ
17 :			*
18 :			* Author: Matthias Blume (blume@tti-c.org)
19 :			*)
20 :			structure BackTrace : sig
21 :			val trigger : unit -> 'a
22 :			val monitor : (unit -> 'a) -> 'a
23 :			val install : unit -> unit
24 :			end = struct
25 :
26 :			structure M = IntRedBlackMap
27 :
28 :			(* Home-cooked set representation:
29 :			* This relies on two things:
30 :			* - we don't need a lookup operation
31 :			* - we only join sets that are known to be disjoint *)
32 :			datatype set =
33 :			EMPTY
34 :			| SINGLETON of int
35 :			| UNION of set * set
36 :
37 :			fun fold f i EMPTY = i
38 :			| fold f i (SINGLETON x) = f (x, i)
39 :			| fold f i (UNION (x, y)) = fold f (fold f i y) x
40 :
41 :			datatype descr =
42 :			STEP of int
43 :			| LOOP of set
44 :
45 :			type stage = { num: int, from: int, descr: descr }
46 :
47 :			type frame = { depth: int, map: int M.map, stages: stage list }
48 :
49 :			type history = frame * frame list
50 :
51 :			datatype state =
52 :			NORMAL of history
53 :			| PENDING of int * history
54 :
55 :			val cur : state ref =
56 :			ref (NORMAL ({ depth = 0, map = M.empty, stages = [] }, []))
57 :
58 :			val names = ref (M.empty: string M.map)
59 :
60 :			fun register (module, _: int, id, s) =
61 :			names := M.insert (!names, module + id, s)
62 :
63 :			fun enter (module, fct) = let
64 :			val i = module + fct
65 :			val (from, front, back) =
66 :			case !cur of
67 :			PENDING (from, (front, back)) => (from, front, back)
68 :			| NORMAL (front, back) => (~1, front, back)
69 :			val { depth, map, stages } = front
70 :			in
71 :			case M.find (map, i) of
72 :			SOME num => let
73 :			fun toSet (STEP i) = SINGLETON i
74 :			| toSet (LOOP s) = s
75 :			fun join (set, d) = UNION (set, toSet d)
76 :			fun finish (stages, from, c, EMPTY) =
77 :			let val stage = { num = num, from = from,
78 :			descr = LOOP (toSet c) }
79 :			val front' = { depth = depth,
80 :			map = map,
81 :			stages = stage :: stages }
82 :			in
83 :			cur := NORMAL (front', back)
84 :			end
85 :			| finish (stages, from, c, set) =
86 :			let val stage = { num = num, from = from,
87 :			descr = LOOP (join (set, c)) }
88 :			fun ins (i, m) = M.insert (m, i, num)
89 :			val front' = { depth = depth,
90 :			map = fold ins map set,
91 :			stages = stage :: stages }
92 :			in
93 :			cur := NORMAL (front', back)
94 :			end
95 :			fun loop ([], set) = () (* cannot happen! *)
96 :			| loop ({ num = n', from, descr = d' } :: t, set) =
97 :			if num = n' then finish (t, from, d', set)
98 :			else loop (t, join (set, d'))
99 :			in
100 :			loop (stages, EMPTY)
101 :			end
102 :			| NONE => let
103 :			val num = case stages of
104 :			[] => 0
105 :			| s0 :: _ => #num s0 + 1
106 :			val stage = { num = num, from = from, descr = STEP i}
107 :			val front' = { depth = depth,
108 :			map = M.insert (map, i, num),
109 :			stages = stage :: stages }
110 :			in
111 :			cur := NORMAL (front' , back)
112 :			end
113 :			end
114 :
115 :			fun push (module, loc) = let
116 :			val id = module + loc
117 :			val (NORMAL old | PENDING (_, old)) = !cur
118 :			val (front, _) = old
119 :			val front' = { depth = #depth front + 1, map = M.empty, stages = [] }
120 :			in
121 :			cur := PENDING (id, (front', op :: old));
122 :			fn () => cur := NORMAL old
123 :			end
124 :
125 :			fun nopush (module, loc) = let
126 :			val id = module + loc
127 :			val (NORMAL old | PENDING (_, old)) = !cur
128 :			in
129 :			cur := PENDING (id, old)
130 :			end
131 :
132 :			fun save () = let
133 :			val old = !cur
134 :			in
135 :			fn () => cur := old
136 :			end
137 :
138 :			fun report () = let
139 :			val (NORMAL top | PENDING (_, top)) = !cur
140 :			val (front, back) = top
141 :			fun do_report () = let
142 :			val (NORMAL bot | PENDING (_, bot)) = !cur
143 :			val (front', _) = bot
144 :			val bot_depth = #depth front'
145 :			fun isBot (f: frame) = #depth f = bot_depth
146 :			fun name (w, pad, from, i) = let
147 :			fun find x = getOpt (M.find (!names, x), "???")
148 :			val n = find i
149 :			val tail = case from of
150 :			NONE => ["\n"]
151 :			| SOME j => ["\n (from: ", find j, ")\n"]
152 :			in
153 :			concat (w :: pad :: " " :: n :: tail)
154 :			end
155 :			fun stage (w, { num, from, descr = STEP i }, a) =
156 :			name (w, " ", SOME from, i) :: a
157 :			| stage (w, { num, from, descr = LOOP s }, a) = let
158 :			fun loop ([], a) = a
159 :			| loop ([i], a) = name (w, "-\\", SOME from, i) :: a
160 :			| loop (h :: t, a) =
161 :			loop (t, name (" ", " |", NONE, h) :: a)
162 :			fun start ([], a) = a
163 :			| start ([i], a) = name (w, "-(", SOME from, i) :: a
164 :			| start (h :: t, a) =
165 :			loop (t, name (" ", " /", NONE, h) :: a)
166 :			in
167 :			start (fold (op ::) [] s, a)
168 :			end
169 :			fun jumps ([], a) = a
170 :			| jumps ([n], a) = stage ("CALL", n, a)
171 :			| jumps (h :: t, a) = jumps (t, stage ("GOTO", h, a))
172 :			fun calls (h, [], a) = jumps (#stages h, a)
173 :			| calls (h, h' :: t, a) = let
174 :			val a = jumps (#stages h, a)
175 :			in
176 :			if isBot h then a else calls (h', t, a)
177 :			end
178 :			in
179 :			rev (calls (front, back, []))
180 :			end
181 :			in
182 :			do_report
183 :			end
184 :
185 :			exception BTraceTriggered of unit -> string list
186 :
187 :	mblume	1866	fun monitor0 (report_final_exn, work) =
188 :	mblume	1758	let val restore = save ()
189 :			fun last (x, []) = x
190 :			| last (_, x :: xs) = last (x, xs)
191 :			fun emsg e =
192 :			case SMLofNJ.exnHistory e of
193 :	mblume	1866	[] => General.exnMessage e
194 :			| (h :: t) =>
195 :			concat [last (h, t), ": ", General.exnMessage e]
196 :	mblume	1758	fun hdl (e, []) =
197 :	mblume	1866	(if report_final_exn then
198 :			Control.Print.say (emsg e ^ "\n\n")
199 :			else ();
200 :	mblume	1758	raise e)
201 :			| hdl (e, hist) =
202 :			(Control.Print.say
203 :			(concat ("\n*** BACK-TRACE ***\n" :: hist));
204 :	mblume	1866	if report_final_exn then
205 :			Control.Print.say (concat ["\n", emsg e, "\n\n"])
206 :			else ();
207 :	mblume	1758	raise e)
208 :			in
209 :			work ()
210 :			handle e as BTraceTriggered do_report =>
211 :			(restore ();
212 :			hdl (e, do_report ()))
213 :			| e =>
214 :			let val do_report = report ()
215 :			in
216 :			restore ();
217 :			hdl (e, do_report ())
218 :			end
219 :			end
220 :
221 :	mblume	1866	fun monitor work = monitor0 (true, work)
222 :
223 :	mblume	1758	val name = "btrace"
224 :
225 :			fun install () =
226 :			let val plugin = { name = name, save = save,
227 :			push = push, nopush = nopush,
228 :			enter = enter, register = register }
229 :	mblume	1866	val monitor = { name = name, monitor = monitor0 }
230 :	mblume	1758	fun addto r x = r := x :: !r
231 :			in
232 :			addto SMLofNJ.Internals.TDP.active_plugins plugin;
233 :			addto SMLofNJ.Internals.TDP.active_monitors monitor
234 :			end
235 :
236 :			fun trigger () = raise BTraceTriggered (report ())
237 :			end

---

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