Annotation of /sml/branches/SMLNJ/src/cml/cml-lib/trace-cml.sml

Parent Directory | Revision Log

---

Revision 29 - (view) (download)

1 :	monnier	2	(* trace-cml.sml
2 :			*
3 :			* COPYRIGHT (c) 1992 AT&T Bell Laboratories
4 :			*
5 :			* This module provides rudimentary debugging support in the form of mechanisms
6 :			* to control debugging output, and to monitor thread termination. This
7 :			* version of this module is adapted from Cliff Krumvieda's utility for tracing
8 :			* CML programs. It provides three facilities: trace modules, for controlling
9 :			* debugging output; thread watching, for detecting thread termination; and
10 :			* a mechanism for reporting uncaught exceptions on a per thread basis.
11 :			*)
12 :
13 :			structure TraceCML : TRACE_CML =
14 :			struct
15 :
16 :			structure SV = SyncVar
17 :
18 :			(* where to direct trace output to *)
19 :			datatype trace_to
20 :			= TraceToOut
21 :			| TraceToErr
22 :			| TraceToNull
23 :			| TraceToFile of string
24 :			| TraceToStream of TextIO.outstream
25 :
26 :			exception NoSuchModule
27 :
28 :			(** Trace Modules **)
29 :			datatype trace_module = TM of {
30 :			full_name : string,
31 :			label : string,
32 :			tracing : bool ref,
33 :			children : trace_module list ref
34 :			}
35 :
36 :			val traceRoot = TM{
37 :			full_name = "/",
38 :			label = "",
39 :			tracing = ref false,
40 :			children = ref []
41 :			}
42 :
43 :			fun forAll f = let
44 :			fun for (tm as TM{children, ...}) = (f tm; forChildren(!children))
45 :			and forChildren [] = ()
46 :			| forChildren (tm::r) = (for tm; forChildren r)
47 :			in
48 :			for
49 :			end
50 :
51 :			structure SS = Substring
52 :
53 :			fun findTraceModule name = let
54 :			fun eq ss (TM{label, ...}) = (SS.compare(SS.all label, ss) = EQUAL)
55 :			fun find ([], tm) = SOME tm
56 :			| find (arc::rest, tm as TM{label, children, ...}) = let
57 :			val eqArc = eq arc
58 :			fun findChild [] = NONE
59 :			| findChild (c::r) =
60 :			if (eqArc c) then find(rest, c) else findChild r
61 :			in
62 :			findChild (!children)
63 :			end
64 :			in
65 :			find (
66 :			SS.tokens (fn #"/" => true | _ => false) (SS.all name),
67 :			traceRoot)
68 :			end
69 :
70 :			fun traceModule' (TM parent, name) = let
71 :			fun checkChildren [] = let
72 :			val tm = TM{
73 :			full_name = (#full_name parent ^ name),
74 :			label = name,
75 :			tracing = ref(!(#tracing parent)),
76 :			children = ref []
77 :			}
78 :			in
79 :			(#children parent) := tm :: !(#children parent);
80 :			tm
81 :			end
82 :			| checkChildren((tm as TM{label, ...})::r) =
83 :			if (label = name) then tm else checkChildren r
84 :			in
85 :			checkChildren (! (#children parent))
86 :			end
87 :
88 :			(* return the name of the module *)
89 :			fun nameOf (TM{full_name, ...}) = full_name
90 :
91 :			(* return the module specified by the given string *)
92 :			fun moduleOf' name = (case findTraceModule name
93 :			of NONE => raise NoSuchModule
94 :			| (SOME tm) => tm
95 :			(* end case *))
96 :
97 :			(* turn tracing on for a module and its descendents *)
98 :			val traceOn' = forAll (fn (TM{tracing, ...}) => tracing := true)
99 :
100 :			(* turn tracing off for a module and its descendents *)
101 :			val traceOff' = forAll (fn (TM{tracing, ...}) => tracing := false)
102 :
103 :			(* turn tracing on for a module (but not for its descendents) *)
104 :			fun traceOnly' (TM{tracing, ...}) = tracing := true
105 :
106 :			(* return true if this module is being traced *)
107 :			fun amTracing (TM{tracing, ...}) = !tracing
108 :
109 :			(* return a list of the registered modules dominated by the given
110 :			* module, and their status.
111 :			*)
112 :			fun status' root = let
113 :			fun list (tm as TM{tracing, children, ...}, l) =
114 :			listChildren (!children, (tm, !tracing)::l)
115 :			and listChildren ([], l) = l
116 :			| listChildren (c::r, l) = listChildren(r, list(c, l))
117 :			in
118 :			rev (list (root, []))
119 :			end
120 :
121 :			(** Trace printing **)
122 :			val traceDst = ref TraceToOut
123 :			val traceCleanup = ref (fn () => ())
124 :
125 :			fun setTraceFile' t = traceDst := t
126 :
127 :			(** NOTE: there are bookkeeping bugs, when changing the trace destination
128 :			** from TraceToStream to something else (where the original destination
129 :			** was TraceToFile).
130 :			**)
131 :			fun tracePrint s = let
132 :			fun output strm = (TextIO.output(strm, s); TextIO.flushOut strm)
133 :			in
134 :			case !traceDst
135 :			of TraceToOut => output TextIO.stdOut
136 :			| TraceToErr => output TextIO.stdErr
137 :			| TraceToNull => ()
138 :			| (TraceToFile fname) => let
139 :			val dst = let
140 :			val strm = TextIO.openOut fname
141 :			in
142 :			traceCleanup := (fn () => TextIO.closeOut strm);
143 :			TraceToStream strm
144 :			end handle _ => (
145 :			Debug.sayDebug(concat[
146 :			"TraceCML: unable to open \"", fname,
147 :			"\", redirecting to stdout"
148 :			]);
149 :			TraceToOut)
150 :			in
151 :			setTraceFile' dst;
152 :			tracePrint s
153 :			end
154 :			| (TraceToStream strm) => output strm
155 :			(* end case *)
156 :			end
157 :
158 :			(** Trace server **)
159 :			val traceCh : (unit -> string list) CML.chan = CML.channel()
160 :			val traceUpdateCh : (unit -> unit) CML.chan = CML.channel()
161 :
162 :			fun traceServer () = let
163 :			val evt = [
164 :			CML.wrap(CML.recvEvt traceCh, fn f => tracePrint(concat(f()))),
165 :			CML.wrap(CML.recvEvt traceUpdateCh, fn f => f())
166 :			]
167 :			fun loop () = (CML.select evt; loop())
168 :			in
169 :			loop()
170 :			end (* traceServer *)
171 :
172 :			fun tracerStart () = (CML.spawn traceServer; ())
173 :			fun tracerStop () = ((!traceCleanup)(); traceCleanup := (fn () => ()))
174 :
175 :			val _ = (
176 :			RunCML.logChannel ("TraceCML:trace", traceCh);
177 :			RunCML.logChannel ("TraceCML:trace-update", traceUpdateCh);
178 :			RunCML.logServer ("TraceCML:trace-server", tracerStart, tracerStop))
179 :
180 :			local
181 :			fun carefully f = if RunCML.isRunning()
182 :			then CML.send(traceUpdateCh, f)
183 :			else f()
184 :			fun carefully' f = if RunCML.isRunning()
185 :			then let
186 :			val reply = SV.iVar()
187 :			in
188 :			CML.send (traceUpdateCh, fn () => (SV.iPut(reply, f())));
189 :			SV.iGet reply
190 :			end
191 :			else f()
192 :			in
193 :			fun traceModule arg = carefully' (fn () => traceModule' arg)
194 :			fun moduleOf name = carefully' (fn () => moduleOf' name)
195 :			fun traceOn tm = carefully (fn () => traceOn' tm)
196 :			fun traceOff tm = carefully (fn () => traceOff' tm)
197 :			fun traceOnly tm = carefully (fn () => traceOnly' tm)
198 :			fun setTraceFile f = carefully (fn () => setTraceFile' f)
199 :			fun status root = carefully' (fn () => status' root)
200 :			end (* local *)
201 :
202 :			fun trace (TM{tracing, ...}, prFn) =
203 :			if (RunCML.isRunning() andalso (!tracing))
204 :			then CML.send(traceCh, prFn)
205 :			else ()
206 :
207 :
208 :			(** Thread watching **)
209 :
210 :			(* controls printing of thread watching messages *)
211 :			val watcher = traceModule (traceRoot, "ThreadWatcher")
212 :			val _ = traceOn watcher
213 :
214 :			datatype watcher_msg
215 :			= WATCH of (CML.thread_id * unit CML.chan)
216 :			| UNWATCH of (CML.thread_id * unit SV.ivar)
217 :
218 :			val watcherMb : watcher_msg Mailbox.mbox = Mailbox.mailbox ()
219 :
220 :			(* stop watching the named thread *)
221 :			fun unwatch tid = let
222 :			val ackV = SV.iVar()
223 :			in
224 :			Mailbox.send(watcherMb, UNWATCH(tid, ackV));
225 :			SV.iGet ackV
226 :			end
227 :
228 :			(* watch the given thread for unexpected termination *)
229 :			fun watch (name, tid) = let
230 :			val unwatchCh = CML.channel()
231 :			fun handleTermination () = (
232 :			trace (watcher, fn () => [
233 :			"WARNING! Watched thread ", name, CML.tidToString tid,
234 :			" has died.\n"
235 :			]);
236 :			unwatch tid)
237 :			fun watcherThread () = (
238 :			Mailbox.send (watcherMb, WATCH(tid, unwatchCh));
239 :			CML.select [
240 :			CML.recvEvt unwatchCh,
241 :			CML.wrap (CML.joinEvt tid, handleTermination)
242 :			])
243 :			in
244 :			CML.spawn (watcherThread); ()
245 :			end
246 :
247 :			structure TidTbl = HashTableFn (
248 :			struct
249 :			type hash_key = CML.thread_id
250 :			val hashVal = CML.hashTid
251 :			val sameKey = CML.sameTid
252 :			end)
253 :
254 :			(* the watcher server *)
255 :			fun startWatcher () = let
256 :			val tbl = TidTbl.mkTable (32, Fail "startWatcher")
257 :			fun loop () = (case (Mailbox.recv watcherMb)
258 :			of (WATCH arg) => TidTbl.insert tbl arg
259 :			| (UNWATCH(tid, ack)) => (
260 :			(* notify the watcher that the thread is no longer being
261 :			* watched, and then acknowledge the unwatch command.
262 :			*)
263 :			CML.send(TidTbl.remove tbl tid, ())
264 :			handle _ => ();
265 :			(* acknowledge that the thread has been removed *)
266 :			SV.iPut(ack, ()))
267 :			(* end case *);
268 :			loop ())
269 :			in
270 :			CML.spawn loop; ()
271 :			end
272 :
273 :			val _ = (
274 :			RunCML.logMailbox ("TraceCML:watcherMb", watcherMb);
275 :			RunCML.logServer ("TraceCML:watcher-server", startWatcher, fn () => ()))
276 :
277 :
278 :			(** Uncaught exception handling **)
279 :
280 :	monnier	29	fun defaultHandlerFn (tid, ex) = let
281 :			val raisedAt = (case (SMLofNJ.exnHistory ex)
282 :			of [] => ["\n"]
283 :			| l => [" raised at ", List.last l, "\n"]
284 :			(* end case *))
285 :			in
286 :			Debug.sayDebug (concat ([
287 :			CML.tidToString tid, " uncaught exception ",
288 :			exnName ex, " [", exnMessage ex, "]"
289 :			] @ raisedAt))
290 :			end
291 :	monnier	2
292 :			val defaultHandler = ref defaultHandlerFn
293 :			val handlers = ref ([] : ((CML.thread_id * exn) -> bool) list)
294 :
295 :			(* this sets the default uncaught exception action. *)
296 :			fun setUncaughtFn' action = defaultHandler := action
297 :
298 :			(* add an additional uncaught exception action. If the action returns
299 :			* true, then no further action is taken. This can be used to handle
300 :			* handle application specific exceptions.
301 :			*)
302 :			fun setHandleFn' action = handlers := action :: !handlers
303 :
304 :			(* this resets the default uncaught exception action to the system default,
305 :			* and removes any layered actions.
306 :			*)
307 :			fun resetUncaughtFn' () = (defaultHandler := defaultHandlerFn; handlers := [])
308 :
309 :			val exnUpdateCh : (unit -> unit) CML.chan = CML.channel()
310 :
311 :			fun exnServerStartup () = let
312 :			val errCh = Mailbox.mailbox()
313 :			(* this function is installed as the default handler for threads;
314 :			* it sends the thread ID and uncaught exception to the ExnServer.
315 :			*)
316 :			fun threadHandler exn = Mailbox.send(errCh, (CML.getTid(), exn))
317 :			(* invoke the hsndler actions on the uncaught exception *)
318 :			fun handleExn arg = let
319 :			val hdlrList = !handlers and dfltHndlr = !defaultHandler
320 :			fun loop [] = dfltHndlr arg
321 :			| loop (hdlr::r) = if (hdlr arg) then () else loop r
322 :			in
323 :			CML.spawn (fn () => ((loop hdlrList) handle _ => (dfltHndlr arg)));
324 :			()
325 :			end
326 :			val event = [
327 :			CML.wrap (CML.recvEvt exnUpdateCh, fn f => f()),
328 :			CML.wrap (Mailbox.recvEvt errCh, handleExn)
329 :			]
330 :			fun server () = (CML.select event; server())
331 :			in
332 :			Thread.defaultExnHandler := threadHandler;
333 :			CML.spawn server; ()
334 :			end
335 :
336 :			val _ = (
337 :			RunCML.logChannel ("TraceCML:exnUpdateCh", exnUpdateCh);
338 :			RunCML.logServer ("TraceCML", exnServerStartup, fn () => ()))
339 :
340 :			local
341 :			fun carefully f = if RunCML.isRunning() then CML.send(exnUpdateCh, f) else f()
342 :			in
343 :			fun setUncaughtFn arg = carefully (fn () => setUncaughtFn' arg)
344 :			fun setHandleFn arg = carefully (fn () => setHandleFn' arg)
345 :			fun resetUncaughtFn arg = carefully (fn () => resetUncaughtFn' arg)
346 :			end (* local *)
347 :
348 :			end; (* TraceCML *)

---

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