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 /sml/branches/SMLNJ/src/cml/cml-lib/trace-cml.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (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 :     fun defaultHandlerFn (tid, ex) =
281 :     Debug.sayDebug (concat [
282 :     CML.tidToString tid, " uncaught exception ",
283 :     exnName ex, " [", exnMessage ex, "]\n"
284 :     ])
285 :    
286 :     val defaultHandler = ref defaultHandlerFn
287 :     val handlers = ref ([] : ((CML.thread_id * exn) -> bool) list)
288 :    
289 :     (* this sets the default uncaught exception action. *)
290 :     fun setUncaughtFn' action = defaultHandler := action
291 :    
292 :     (* add an additional uncaught exception action. If the action returns
293 :     * true, then no further action is taken. This can be used to handle
294 :     * handle application specific exceptions.
295 :     *)
296 :     fun setHandleFn' action = handlers := action :: !handlers
297 :    
298 :     (* this resets the default uncaught exception action to the system default,
299 :     * and removes any layered actions.
300 :     *)
301 :     fun resetUncaughtFn' () = (defaultHandler := defaultHandlerFn; handlers := [])
302 :    
303 :     val exnUpdateCh : (unit -> unit) CML.chan = CML.channel()
304 :    
305 :     fun exnServerStartup () = let
306 :     val errCh = Mailbox.mailbox()
307 :     (* this function is installed as the default handler for threads;
308 :     * it sends the thread ID and uncaught exception to the ExnServer.
309 :     *)
310 :     fun threadHandler exn = Mailbox.send(errCh, (CML.getTid(), exn))
311 :     (* invoke the hsndler actions on the uncaught exception *)
312 :     fun handleExn arg = let
313 :     val hdlrList = !handlers and dfltHndlr = !defaultHandler
314 :     fun loop [] = dfltHndlr arg
315 :     | loop (hdlr::r) = if (hdlr arg) then () else loop r
316 :     in
317 :     CML.spawn (fn () => ((loop hdlrList) handle _ => (dfltHndlr arg)));
318 :     ()
319 :     end
320 :     val event = [
321 :     CML.wrap (CML.recvEvt exnUpdateCh, fn f => f()),
322 :     CML.wrap (Mailbox.recvEvt errCh, handleExn)
323 :     ]
324 :     fun server () = (CML.select event; server())
325 :     in
326 :     Thread.defaultExnHandler := threadHandler;
327 :     CML.spawn server; ()
328 :     end
329 :    
330 :     val _ = (
331 :     RunCML.logChannel ("TraceCML:exnUpdateCh", exnUpdateCh);
332 :     RunCML.logServer ("TraceCML", exnServerStartup, fn () => ()))
333 :    
334 :     local
335 :     fun carefully f = if RunCML.isRunning() then CML.send(exnUpdateCh, f) else f()
336 :     in
337 :     fun setUncaughtFn arg = carefully (fn () => setUncaughtFn' arg)
338 :     fun setHandleFn arg = carefully (fn () => setHandleFn' arg)
339 :     fun resetUncaughtFn arg = carefully (fn () => resetUncaughtFn' arg)
340 :     end (* local *)
341 :    
342 :     end; (* TraceCML *)

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