[hcoop/debian/mlton.git] / lib / cml / cml-lib / trace-cml.sml

(* trace-cml.sml
 *
 * COPYRIGHT (c) 1992 AT&T Bell Laboratories
 *
 * This module provides rudimentary debugging support in the form of mechanisms
 * to control debugging output, and to monitor thread termination.  This
 * version of this module is adapted from Cliff Krumvieda's utility for tracing
 * CML programs.  It provides three facilities: trace modules, for controlling
 * debugging output; thread watching, for detecting thread termination; and
 * a mechanism for reporting uncaught exceptions on a per thread basis.
 *)

structure TraceCML : TRACE_CML =
  struct

    structure SV = SyncVar

  (* where to direct trace output to *)
    datatype trace_to
      = TraceToOut
      | TraceToErr
      | TraceToNull
      | TraceToFile of string
      | TraceToStream of TextIO.outstream

    exception NoSuchModule

  (** Trace Modules **)
    datatype trace_module = TM of {
        full_name : string,
        label : string,
        tracing : bool ref,
        children : trace_module list ref
      }

    val traceRoot = TM{
            full_name = "/",
            label = "",
            tracing = ref false,
            children = ref []
          }

    fun forAll f = let
          fun for (tm as TM{children, ...}) = (f tm; forChildren(!children))
          and forChildren [] = ()
            | forChildren (tm::r) = (for tm; forChildren r)
          in
            for
          end

    structure SS = Substring

    fun findTraceModule name = let
          fun eq ss (TM{label, ...}) = (SS.compare(SS.all label, ss) = EQUAL)
          fun find ([], tm) = SOME tm
            | find (arc::rest, tm as TM{label, children, ...}) = let
                val eqArc = eq arc
                fun findChild [] = NONE
                  | findChild (c::r) =
                      if (eqArc c) then find(rest, c) else findChild r
                in
                  findChild (!children)
                end
          in
            find (
              SS.tokens (fn #"/" => true | _ => false) (SS.all name),
              traceRoot)
          end

    fun traceModule' (TM parent, name) = let
          fun checkChildren [] = let
                val tm = TM{
                        full_name = (#full_name parent ^ name),
                        label = name,
                        tracing = ref(!(#tracing parent)),
                        children = ref []
                      }
                in
                  (#children parent) := tm :: !(#children parent);
                  tm
                end
            | checkChildren((tm as TM{label, ...})::r) =
                if (label = name) then tm else checkChildren r
          in
            checkChildren (! (#children parent))
          end

  (* return the name of the module *)
    fun nameOf (TM{full_name, ...}) = full_name

  (* return the module specified by the given string *)
    fun moduleOf' name = (case findTraceModule name
           of NONE => raise NoSuchModule
            | (SOME tm) => tm
          (* end case *))

  (* turn tracing on for a module and its descendents *)
    val traceOn' = forAll (fn (TM{tracing, ...}) => tracing := true)

  (* turn tracing off for a module and its descendents *)
    val traceOff' = forAll (fn (TM{tracing, ...}) => tracing := false)

  (* turn tracing on for a module (but not for its descendents) *)
    fun traceOnly' (TM{tracing, ...}) = tracing := true

  (* return true if this module is being traced *)
    fun amTracing (TM{tracing, ...}) = !tracing

  (* return a list of the registered modules dominated by the given
   * module, and their status.
   *)
    fun status' root = let
          fun list (tm as TM{tracing, children, ...}, l) =
                listChildren (!children, (tm, !tracing)::l)
          and listChildren ([], l) = l
            | listChildren (c::r, l) = listChildren(r, list(c, l))
          in
            rev (list (root, []))
          end

  (** Trace printing **)
    val traceDst = ref TraceToOut
    val traceCleanup = ref (fn () => ())

    fun setTraceFile'  t = traceDst := t

(** NOTE: there are bookkeeping bugs, when changing the trace destination
 ** from TraceToStream to something else (where the original destination 
 ** was TraceToFile).
 **)
    fun tracePrint s = let
          fun output strm = (TextIO.output(strm, s); TextIO.flushOut strm)
          in
            case !traceDst
             of TraceToOut => output TextIO.stdOut
              | TraceToErr => output TextIO.stdErr
              | TraceToNull => ()
              | (TraceToFile fname) => let
                  val dst = let
                        val strm = TextIO.openOut fname
                        in
                          traceCleanup := (fn () => TextIO.closeOut strm);
                          TraceToStream strm
                        end handle _ => (
                          Debug.sayDebug(concat[
                              "TraceCML: unable to open \"", fname,
                              "\", redirecting to stdout"
                            ]);
                          TraceToOut)
                  in
                    setTraceFile' dst;
                    tracePrint s
                  end
                | (TraceToStream strm) => output strm
            (* end case *)
          end

  (** Trace server **)
    val traceCh : (unit -> string list) CML.chan = CML.channel()
    val traceUpdateCh : (unit -> unit) CML.chan = CML.channel()

    fun traceServer () = let
          val evt = [
                  CML.wrap(CML.recvEvt traceCh, fn f => tracePrint(concat(f()))),
                  CML.wrap(CML.recvEvt traceUpdateCh, fn f => f())
                ]
          fun loop () = (CML.select evt; loop())
          in
            loop()
          end (* traceServer *)

    fun tracerStart () = (CML.spawn traceServer; ())
    fun tracerStop () = ((!traceCleanup)(); traceCleanup := (fn () => ()))

    val _ = (
          RunCML.logChannel ("TraceCML:trace", traceCh);
          RunCML.logChannel ("TraceCML:trace-update", traceUpdateCh);
          RunCML.logServer ("TraceCML:trace-server", tracerStart, tracerStop))

    local
      fun carefully f = if RunCML.isRunning()
            then CML.send(traceUpdateCh, f)
            else f()
      fun carefully' f = if RunCML.isRunning()
              then let
                val reply = SV.iVar()
                in
                  CML.send (traceUpdateCh, fn () => (SV.iPut(reply, f())));
                  SV.iGet reply
                end
              else f()
    in
    fun traceModule arg = carefully' (fn () => traceModule' arg)
    fun moduleOf name = carefully' (fn () => moduleOf' name)
    fun traceOn tm = carefully (fn () => traceOn' tm)
    fun traceOff tm = carefully (fn () => traceOff' tm)
    fun traceOnly tm = carefully (fn () => traceOnly' tm)
    fun setTraceFile f = carefully (fn () => setTraceFile' f)
    fun status root = carefully' (fn () => status' root)
    end (* local *)

    fun trace (TM{tracing, ...}, prFn) =
          if (RunCML.isRunning() andalso (!tracing))
            then CML.send(traceCh, prFn)
            else ()


  (** Thread watching **)

  (* controls printing of thread watching messages *)
    val watcher = traceModule (traceRoot, "ThreadWatcher")
    val _ = traceOn watcher

    datatype watcher_msg
      = WATCH of (CML.thread_id * unit CML.chan)
      | UNWATCH of (CML.thread_id * unit SV.ivar)

    val watcherMb : watcher_msg Mailbox.mbox = Mailbox.mailbox ()

  (* stop watching the named thread *)
    fun unwatch tid = let
          val ackV = SV.iVar()
          in
            Mailbox.send(watcherMb, UNWATCH(tid, ackV));
            SV.iGet ackV
          end

  (* watch the given thread for unexpected termination *)
    fun watch (name, tid) = let
          val unwatchCh = CML.channel()
          fun handleTermination () = (
                trace (watcher, fn () => [
                    "WARNING!  Watched thread ", name, CML.tidToString tid,
                    " has died.\n"
                  ]);
                unwatch tid)
          fun watcherThread () = (
                Mailbox.send (watcherMb, WATCH(tid, unwatchCh));
                CML.select [
                    CML.recvEvt unwatchCh,
                    CML.wrap (CML.joinEvt tid, handleTermination)
                  ])
          in
            CML.spawn (watcherThread); ()
          end

    structure TidTbl = HashTableFn (
      struct
        type hash_key = CML.thread_id
        val hashVal = CML.hashTid
        val sameKey = CML.sameTid
      end)

  (* the watcher server *)
    fun startWatcher () = let
          val tbl = TidTbl.mkTable (32, Fail "startWatcher")
          fun loop () = (case (Mailbox.recv watcherMb)
                 of (WATCH arg) => TidTbl.insert tbl arg
                  | (UNWATCH(tid, ack)) => (
                    (* notify the watcher that the thread is no longer being
                     * watched, and then acknowledge the unwatch command.
                     *)
                      CML.send(TidTbl.remove tbl tid, ())
                        handle _ => ();
                    (* acknowledge that the thread has been removed *)
                      SV.iPut(ack, ()))
                (* end case *);
                loop ())
          in
            CML.spawn loop; ()
          end

    val _ = (
          RunCML.logMailbox ("TraceCML:watcherMb", watcherMb);
          RunCML.logServer ("TraceCML:watcher-server", startWatcher, fn () => ()))


  (** Uncaught exception handling **)

    fun defaultHandlerFn (tid, ex) = let
          val raisedAt = (case (SMLofNJ.exnHistory ex)
                 of [] => ["\n"]
                  | l => [" raised at ", List.last l, "\n"]
                (* end case *))
          in
            Debug.sayDebug (concat ([
                CML.tidToString tid, " uncaught exception ",
                exnName ex, " [", exnMessage ex, "]"
              ] @ raisedAt))
          end

    val defaultHandler = ref defaultHandlerFn
    val handlers = ref ([] : ((CML.thread_id * exn) -> bool) list)

  (* this sets the default uncaught exception action. *)
    fun setUncaughtFn' action = defaultHandler := action

  (* add an additional uncaught exception action.  If the action returns
   * true, then no further action is taken.  This can be used to handle
   * handle application specific exceptions.
   *)
    fun setHandleFn' action = handlers := action :: !handlers

  (* this resets the default uncaught exception action to the system default,
   * and removes any layered actions.
   *)
    fun resetUncaughtFn' () = (defaultHandler := defaultHandlerFn; handlers := [])

    val exnUpdateCh : (unit -> unit) CML.chan = CML.channel()

    fun exnServerStartup () = let
          val errCh = Mailbox.mailbox()
        (* this function is installed as the default handler for threads;
         * it sends the thread ID and uncaught exception to the ExnServer.
         *)
          fun threadHandler exn = Mailbox.send(errCh, (CML.getTid(), exn))
        (* invoke the hsndler actions on the uncaught exception *)
          fun handleExn arg = let
                val hdlrList = !handlers and dfltHndlr = !defaultHandler
                fun loop [] = dfltHndlr arg
                  | loop (hdlr::r) = if (hdlr arg) then () else loop r
                in
                  CML.spawn (fn () => ((loop hdlrList) handle _ => (dfltHndlr arg)));
                  ()
                end
          val event = [
                  CML.wrap (CML.recvEvt exnUpdateCh, fn f => f()),
                  CML.wrap (Mailbox.recvEvt errCh, handleExn)
                ]
          fun server () = (CML.select event; server())
          in
            Thread.defaultExnHandler := threadHandler;
            CML.spawn server; ()
          end

    val _ = (
          RunCML.logChannel ("TraceCML:exnUpdateCh", exnUpdateCh);
          RunCML.logServer ("TraceCML", exnServerStartup, fn () => ()))

    local
      fun carefully f = if RunCML.isRunning() then CML.send(exnUpdateCh, f) else f()
    in
    fun setUncaughtFn arg = carefully (fn () => setUncaughtFn' arg)
    fun setHandleFn arg = carefully (fn () => setHandleFn' arg)
    fun resetUncaughtFn arg = carefully (fn () => resetUncaughtFn' arg)
    end (* local *)

  end; (* TraceCML *)
Commit	Line	Data
7f918cf1 CE	1	(* 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) = 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
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 *)