3 * COPYRIGHT (c
) 1992 AT
&T Bell Laboratories
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
.
13 structure TraceCML
: TRACE_CML
=
16 structure SV
= SyncVar
18 (* where to direct trace output to
*)
23 | TraceToFile
of string
24 | TraceToStream
of TextIO.outstream
26 exception NoSuchModule
29 datatype trace_module
= TM
of {
33 children
: trace_module list ref
44 fun for (tm
as TM
{children
, ...}) = (f tm
; forChildren(!children
))
45 and forChildren
[] = ()
46 |
forChildren (tm
::r
) = (for tm
; forChildren r
)
51 structure SS
= Substring
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
58 fun findChild
[] = NONE
60 if (eqArc c
) then find(rest
, c
) else findChild r
66 SS
.tokens (fn #
"/" => true | _
=> false) (SS
.all name
),
70 fun traceModule
' (TM parent
, name
) = let
71 fun checkChildren
[] = let
73 full_name
= (#full_name parent ^ name
),
75 tracing
= ref(!(#tracing parent
)),
79 (#children parent
) := tm
:: !(#children parent
);
82 |
checkChildren((tm
as TM
{label
, ...})::r
) =
83 if (label
= name
) then tm
else checkChildren r
85 checkChildren (! (#children parent
))
88 (* return the name
of the module
*)
89 fun nameOf (TM
{full_name
, ...}) = full_name
91 (* return the module specified by the given
string *)
92 fun moduleOf
' name
= (case findTraceModule name
93 of NONE
=> raise NoSuchModule
97 (* turn tracing on for a module
and its descendents
*)
98 val traceOn
' = forAll (fn (TM
{tracing
, ...}) => tracing
:= true)
100 (* turn tracing off for a module
and its descendents
*)
101 val traceOff
' = forAll (fn (TM
{tracing
, ...}) => tracing
:= false)
103 (* turn tracing on for a
module (but not for its descendents
) *)
104 fun traceOnly
' (TM
{tracing
, ...}) = tracing
:= true
106 (* return
true if this module is being traced
*)
107 fun amTracing (TM
{tracing
, ...}) = !tracing
109 (* return a list
of the registered modules dominated by the given
110 * module
, and their status
.
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
))
118 rev (list (root
, []))
121 (** Trace printing
**)
122 val traceDst
= ref TraceToOut
123 val traceCleanup
= ref (fn () => ())
125 fun setTraceFile
' t
= traceDst
:= t
127 (** NOTE
: there are bookkeeping bugs
, when changing the trace destination
128 ** from TraceToStream to something
else (where the original destination
131 fun tracePrint s
= let
132 fun output strm
= (TextIO.output(strm
, s
); TextIO.flushOut strm
)
135 of TraceToOut
=> output
TextIO.stdOut
136 | TraceToErr
=> output
TextIO.stdErr
138 |
(TraceToFile fname
) => let
140 val strm
= TextIO.openOut fname
142 traceCleanup
:= (fn () => TextIO.closeOut strm
);
145 Debug
.sayDebug(concat
[
146 "TraceCML: unable to open \"", fname
,
147 "\", redirecting to stdout"
154 |
(TraceToStream strm
) => output strm
159 val traceCh
: (unit
-> string list
) CML
.chan
= CML
.channel()
160 val traceUpdateCh
: (unit
-> unit
) CML
.chan
= CML
.channel()
162 fun traceServer () = let
164 CML
.wrap(CML
.recvEvt traceCh
, fn f
=> tracePrint(concat(f()))),
165 CML
.wrap(CML
.recvEvt traceUpdateCh
, fn f
=> f())
167 fun loop () = (CML
.select evt
; loop())
170 end (* traceServer
*)
172 fun tracerStart () = (CML
.spawn traceServer
; ())
173 fun tracerStop () = ((!traceCleanup
)(); traceCleanup
:= (fn () => ()))
176 RunCML
.logChannel ("TraceCML:trace", traceCh
);
177 RunCML
.logChannel ("TraceCML:trace-update", traceUpdateCh
);
178 RunCML
.logServer ("TraceCML:trace-server", tracerStart
, tracerStop
))
181 fun carefully f
= if RunCML
.isRunning()
182 then CML
.send(traceUpdateCh
, f
)
184 fun carefully
' f
= if RunCML
.isRunning()
186 val reply
= SV
.iVar()
188 CML
.send (traceUpdateCh
, fn () => (SV
.iPut(reply
, f())));
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
)
202 fun trace (TM
{tracing
, ...}, prFn
) =
203 if (RunCML
.isRunning() andalso (!tracing
))
204 then CML
.send(traceCh
, prFn
)
208 (** Thread watching
**)
210 (* controls printing
of thread watching messages
*)
211 val watcher
= traceModule (traceRoot
, "ThreadWatcher")
212 val _
= traceOn watcher
215 = WATCH
of (CML
.thread_id
* unit CML
.chan
)
216 | UNWATCH
of (CML
.thread_id
* unit SV
.ivar
)
218 val watcherMb
: watcher_msg Mailbox
.mbox
= Mailbox
.mailbox ()
220 (* stop watching the named thread
*)
221 fun unwatch tid
= let
224 Mailbox
.send(watcherMb
, UNWATCH(tid
, ackV
));
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
,
237 fun watcherThread () = (
238 Mailbox
.send (watcherMb
, WATCH(tid
, unwatchCh
));
240 CML
.recvEvt unwatchCh
,
241 CML
.wrap (CML
.joinEvt tid
, handleTermination
)
244 CML
.spawn (watcherThread
); ()
247 structure TidTbl
= HashTableFn (
249 type hash_key
= CML
.thread_id
250 val hashVal
= CML
.hashTid
251 val sameKey
= CML
.sameTid
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
.
263 CML
.send(TidTbl
.remove tbl tid
, ())
265 (* acknowledge that the thread has been removed
*)
274 RunCML
.logMailbox ("TraceCML:watcherMb", watcherMb
);
275 RunCML
.logServer ("TraceCML:watcher-server", startWatcher
, fn () => ()))
278 (** Uncaught
exception handling
**)
280 fun defaultHandlerFn (tid
, ex
) = let
281 val raisedAt
= (case (SMLofNJ
.exnHistory ex
)
283 | l
=> [" raised at ", List.last l
, "\n"]
286 Debug
.sayDebug (concat ([
287 CML
.tidToString tid
, " uncaught exception ",
288 exnName ex
, " [", exnMessage ex
, "]"
292 val defaultHandler
= ref defaultHandlerFn
293 val handlers
= ref ([] : ((CML
.thread_id
* exn
) -> bool) list
)
295 (* this sets the default uncaught
exception action
. *)
296 fun setUncaughtFn
' action
= defaultHandler
:= action
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
.
302 fun setHandleFn
' action
= handlers
:= action
:: !handlers
304 (* this resets the default uncaught
exception action to the system default
,
305 * and removes any layered actions
.
307 fun resetUncaughtFn
' () = (defaultHandler
:= defaultHandlerFn
; handlers
:= [])
309 val exnUpdateCh
: (unit
-> unit
) CML
.chan
= CML
.channel()
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
.
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
323 CML
.spawn (fn () => ((loop hdlrList
) handle _
=> (dfltHndlr arg
)));
327 CML
.wrap (CML
.recvEvt exnUpdateCh
, fn f
=> f()),
328 CML
.wrap (Mailbox
.recvEvt errCh
, handleExn
)
330 fun server () = (CML
.select event
; server())
332 Thread
.defaultExnHandler
:= threadHandler
;
337 RunCML
.logChannel ("TraceCML:exnUpdateCh", exnUpdateCh
);
338 RunCML
.logServer ("TraceCML", exnServerStartup
, fn () => ()))
341 fun carefully f
= if RunCML
.isRunning() then CML
.send(exnUpdateCh
, f
) else f()
343 fun setUncaughtFn arg
= carefully (fn () => setUncaughtFn
' arg
)
344 fun setHandleFn arg
= carefully (fn () => setHandleFn
' arg
)
345 fun resetUncaughtFn arg
= carefully (fn () => resetUncaughtFn
' arg
)