[hcoop/debian/mlton.git] / lib / mlton / basic / trace.sml

(* Copyright (C) 2009 Matthew Fluet.
 * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

functor TraceControl (structure StringMap: STRING_MAP
                      datatype status = Always | Flagged | Never
                      type flags
                      val map: flags StringMap.t
                      val getFlag: flags -> bool ref
                      val default: bool ref
                      val status: status) =
struct

val status = ref status

fun always () = status := Always
fun flagged () = status := Flagged
fun never () = status := Never

fun isOn b =
   case !status of
      Always => true
    | Flagged => !b
    | Never => false

val default = default

fun flag name = getFlag (StringMap.lookup (map, name))

fun whats b () = StringMap.keepAll (map, fn flags => b = !(getFlag flags))

val whatsOn = whats true
val whatsOff = whats false

fun sets b () =
   StringMap.foreach (map, fn flags => getFlag flags := b)

val all = sets true
val none = sets false

fun some b ss = List.foreach (ss, fn s => flag s := b)

val on = some true
val off = some false

end

(*-------------------------------------------------------------------*)
(*                               Trace                               *)
(*-------------------------------------------------------------------*)

structure Trace: TRACE =
struct

structure IC = IntermediateComputation
structure Timer = Time

val immediateDefault = ref false
val delayedDefault = ref false
val timeDefault = ref false

type flags = {immediate: bool ref,
              delayed: bool ref,
              time: bool ref}

val map = StringMap.new (fn () => {immediate = ref (!immediateDefault),
                                   delayed = ref (!delayedDefault),
                                   time = ref (!timeDefault)})

fun traceable () = StringMap.domain map

fun outputTraceable () =
   Layout.output (List.layout Layout.str (traceable ()),
                 Out.standard)

datatype status = Always | Flagged | Never

structure Immediate =
   TraceControl (type flags = flags
                 val map = map
                 structure StringMap = StringMap
                 datatype status = datatype status
                 fun getFlag ({immediate, ...}: flags) = immediate
                 val default = immediateDefault
                 val status = Never)
structure Delayed =
   struct
      structure C = 
         TraceControl (type flags = flags
                      val map = map
                      structure StringMap = StringMap
                      datatype status = datatype status
                      fun getFlag ({delayed, ...}: flags) = delayed
                      val default = delayedDefault
                      val status = Never)
      open C

      val keepAll = ref true
   end

structure Time =
   TraceControl (type flags = flags
                val map = map
                structure StringMap = StringMap
                datatype status = datatype status
                fun getFlag ({time, ...}: flags) = time
                val default = timeDefault
                val status = Never)

fun never () = (Immediate.never ()
               ; Delayed.never ()
               ; Time.never ())

fun always () = (Immediate.always ()
                ; Delayed.always ()
                ; Time.always ())

fun flagged () = (Immediate.flagged ()
                 ; Delayed.flagged ()
                 ; Time.flagged ())

fun reset () =
   StringMap.foreach (map, fn {immediate, delayed, time} =>
                      (immediate := false
                       ; delayed := false
                       ; time := false))

(*---------------------------------------------------*)
(*                 Delayed Feedback                  *)
(*---------------------------------------------------*)

structure Computation = IC.Computation

datatype comp =
   Working of IC.t
  | Finished of Computation.t

val emptyIc = IC.empty
fun empty () = Working (emptyIc ())

val currentComputation = ref (empty ())

fun clear () = currentComputation := empty ()

fun finishedComputation () =
   case !currentComputation of
      Working ic => let val c = IC.finish ic
                    in currentComputation := Finished c
                       ; c
                    end
    | Finished c => c
val computation = finishedComputation

fun history () = Computation.output (finishedComputation (),
                                   Out.error)
fun calls () = Computation.outputCalls (finishedComputation (),
                                      Out.error)
fun times () = Computation.outputTimes (finishedComputation (),
                                      Out.error)
fun inspect () = Computation.inspect (finishedComputation ())

fun ic () =
   case !currentComputation of
      Finished _ => let val ic = emptyIc ()
                    in currentComputation := Working ic
                       ; ic
                    end
    | Working ic => ic

fun delayedCall (name, layoutArg, layoutAns) =
   {call = fn () =>
    let val comp = ic ()
       val comp = if !Delayed.keepAll orelse not (IC.atTopLevel comp)
                     then comp
                  else (clear (); ic ())
    in IC.call (comp, name, layoutArg)
    end,
    raisee = fn (t, _) => IC.raisee (ic (), t),
    return = fn (ans, t) => IC.return (ic (),
                                     fn () => layoutAns ans,
                                     t)}

(*---------------------------------------------------*)
(*                Immediate Feedback                 *)
(*---------------------------------------------------*)

structure Immediate =
   struct
      open Immediate

      datatype debug =
         None
       | Terminal
       | Out of Out.t

      val debug = ref None

      val showTime = ref false

      val indentation: int ref = ref 0
      val space: int = 3
      fun left () = indentation := !indentation - space
      fun right () = indentation := !indentation + space

      val inChild = ref false
      fun inChildProcess () = (inChild := true; indentation := 0)

      fun message (l: Layout.t): unit =
         case !debug of
            None => ()
          | _ => 
               let
                  val (out, done) =
                     case !debug of
                        Terminal => (Out.openOut "/dev/tty", Out.close)
                      | Out out => (out, Out.flush)
                      | _ => Error.bug "Trace.message"
                  open Layout
               in output (seq [if !inChild
                                then seq [Pid.layout (Pid.current ()), str ": "]
                             else empty,
                             if !showTime
                                then str (Date.fmt
                                          (Date.now (), "%b %d %H:%M:%S "))
                             else empty,
                             indent (l, !indentation)],
                         out)
                  ; Out.newline out
                  ; done out
               end

      fun finish (t, res) =
         (left ()
          ; message (let open Layout
                    in case t of
                       NONE => seq [str "==> ", res]
                     | SOME t =>
                          align [seq [str "==> time = ", Timer.layout t],
                                res]
                    end))

      fun call (name, outArg, layoutAns) =
         let
            open Layout
            fun call () = (message (seq [str name, str " ==> ",
                                         outArg ()
                                         handle e =>
                                            seq [str "layout argument error: ",
                                                 Exn.layout e]])
                           ; right ())
            fun raisee (t, e) = finish (t, seq [str "raise: ", Exn.layout e])
            fun return (ans, t) =
               finish (t,
                       layoutAns ans
                       handle e => seq [str "layout answer error: ",
                                        Exn.layout e])
         in {call = call,
             raisee = raisee,
             return = return}
         end

      val message =
         fn l =>
         (left ()
          ; indentation := 1 + !indentation
          ; message l
          ; indentation := !indentation - 1
          ; right ())

      val messageStr = message o Layout.str
   end

(*---------------------------------------------------*)
(*                  Instrumentation                  *)
(*---------------------------------------------------*)

type info = {name: string, flags: flags}

val bogusInfo = {name = "bogus", flags = {delayed = ref false,
                                          immediate = ref false,
                                          time = ref false}}

val shouldTrace = Assert.debug

fun info name =
   if shouldTrace
      then {name = name, flags = StringMap.lookup (map, name)}
   else bogusInfo

fun traceInfo ({name, flags = {immediate, delayed, time}},
               layoutArg, layoutAns, check) f a =
   if not shouldTrace
      then f a
   else 
      let
         val immediate = Immediate.isOn immediate
         val delayed = Delayed.isOn delayed
         val time = Time.isOn time
      in
         if not (immediate orelse delayed orelse time orelse Assert.debug)
            then f a
         else let val outArg = fn () => layoutArg a
                  val noCall = {call = fn _ => (),
                                raisee = fn _ => (),
                                return = fn _ => ()}
                  val immed = if immediate
                                 then Immediate.call (name, outArg, layoutAns)
                              else noCall
                  val delay = if delayed
                                 then delayedCall (name, outArg, layoutAns)
                              else noCall
                  val _ = (#call delay ()
                           ; #call immed ())
                  val check =
                     if Assert.debug
                        then let val (b, check) = check a
                                 val _ = Assert.assert (concat [name, " argument"],
                                                       fn () => b)
                             in check
                             end
                     else fn _ => true
                  val startTime = if time then SOME (Timer.times ()) else NONE
                  fun getTime () =
                     case startTime of
                        NONE => NONE
                      | SOME {self = {utime = u, stime = s}, ...} =>
                           SOME (let val {self = {utime = u', stime = s'},
                                          ...} = Timer.times ()
                                in Timer.+ (Timer.- (u', u),
                                            Timer.- (s', s))
                                end)
                  val ans = f a handle exn => let val t = getTime ()
                                              in #raisee delay (t, exn)
                                                 ; #raisee immed (t, exn)
                                                 ; raise exn
                                              end
                  val t = getTime ()
              in #return delay (ans, t)
                 ; #return immed (ans, t)
                 ; Assert.assert (concat [name, " result"], fn () => check ans)
                 ; ans
              end
      end

fun assertTrue _ = (true, fn _ => true)

fun traceInfo' (info, layoutArg, layoutAns) =
   traceInfo (info, layoutArg, layoutAns, assertTrue)

fun traceAssert (name, layoutArg, layoutAns, check) =
   traceInfo (info name, layoutArg, layoutAns, check)

fun trace (name, layoutArg, layoutAns) =
   traceAssert (name, layoutArg, layoutAns, assertTrue)

fun ignore _ = Layout.empty

fun traceCall s = trace (s, ignore, ignore)

fun traceRec info =
   let val trace = trace info
   in fn f => let fun fix f a = trace (f (fix f)) a
              in fix f
              end
   end

fun trace0 (name, layoutAns) =
   trace (name, Unit.layout, layoutAns)

fun trace2 (name, layout1, layout2, layoutAns) =
   trace (name, Layout.tuple2 (layout1, layout2), layoutAns)

fun trace3 (name, out1, out2, out3, outAns) =
   trace (name, Layout.tuple3 (out1, out2, out3), outAns)

fun trace4 (name, out1, out2, out3, out4, outAns) =
   trace (name, Layout.tuple4 (out1, out2, out3, out4), outAns)

fun trace5 (name, out1, out2, out3, out4, out5, outAns) =
   trace (name, Layout.tuple5 (out1, out2, out3, out4, out5), outAns)

end

structure Computation = Trace.Computation
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 2009 Matthew Fluet.
	2	* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
	3	* Jagannathan, and Stephen Weeks.
	4	*
	5	* MLton is released under a BSD-style license.
	6	* See the file MLton-LICENSE for details.
	7	*)
	8
	9	functor TraceControl (structure StringMap: STRING_MAP
	10	datatype status = Always \| Flagged \| Never
	11	type flags
	12	val map: flags StringMap.t
	13	val getFlag: flags -> bool ref
	14	val default: bool ref
	15	val status: status) =
	16	struct
	17
	18	val status = ref status
	19
	20	fun always () = status := Always
	21	fun flagged () = status := Flagged
	22	fun never () = status := Never
	23
	24	fun isOn b =
	25	case !status of
	26	Always => true
	27	\| Flagged => !b
	28	\| Never => false
	29
	30	val default = default
	31
	32	fun flag name = getFlag (StringMap.lookup (map, name))
	33
	34	fun whats b () = StringMap.keepAll (map, fn flags => b = !(getFlag flags))
	35
	36	val whatsOn = whats true
	37	val whatsOff = whats false
	38
	39	fun sets b () =
	40	StringMap.foreach (map, fn flags => getFlag flags := b)
	41
	42	val all = sets true
	43	val none = sets false
	44
	45	fun some b ss = List.foreach (ss, fn s => flag s := b)
	46
	47	val on = some true
	48	val off = some false
	49
	50	end
	51
	52	(-------------------------------------------------------------------)
	53	(* Trace *)
	54	(-------------------------------------------------------------------)
	55
	56	structure Trace: TRACE =
	57	struct
	58
	59	structure IC = IntermediateComputation
	60	structure Timer = Time
	61
	62	val immediateDefault = ref false
	63	val delayedDefault = ref false
	64	val timeDefault = ref false
65
66	type flags = {immediate: bool ref,
67	delayed: bool ref,
68	time: bool ref}
69
70	val map = StringMap.new (fn () => {immediate = ref (!immediateDefault),
71	delayed = ref (!delayedDefault),
72	time = ref (!timeDefault)})
73
74	fun traceable () = StringMap.domain map
75
76	fun outputTraceable () =
77	Layout.output (List.layout Layout.str (traceable ()),
78	Out.standard)
79
80	datatype status = Always \| Flagged \| Never
81
82	structure Immediate =
83	TraceControl (type flags = flags
84	val map = map
85	structure StringMap = StringMap
86	datatype status = datatype status
87	fun getFlag ({immediate, ...}: flags) = immediate
88	val default = immediateDefault
89	val status = Never)
90	structure Delayed =
91	struct
92	structure C =
93	TraceControl (type flags = flags
94	val map = map
95	structure StringMap = StringMap
96	datatype status = datatype status
97	fun getFlag ({delayed, ...}: flags) = delayed
98	val default = delayedDefault
99	val status = Never)
100	open C
101
102	val keepAll = ref true
103	end
104
105	structure Time =
106	TraceControl (type flags = flags
107	val map = map
108	structure StringMap = StringMap
109	datatype status = datatype status
110	fun getFlag ({time, ...}: flags) = time
111	val default = timeDefault
112	val status = Never)
113
114	fun never () = (Immediate.never ()
115	; Delayed.never ()
116	; Time.never ())
117
118	fun always () = (Immediate.always ()
119	; Delayed.always ()
120	; Time.always ())
121
122	fun flagged () = (Immediate.flagged ()
123	; Delayed.flagged ()
124	; Time.flagged ())
125
126	fun reset () =
127	StringMap.foreach (map, fn {immediate, delayed, time} =>
128	(immediate := false
129	; delayed := false
130	; time := false))
131
132	(---------------------------------------------------)
133	(* Delayed Feedback *)
134	(---------------------------------------------------)
135
136	structure Computation = IC.Computation
137
138	datatype comp =
139	Working of IC.t
140	\| Finished of Computation.t
141
142	val emptyIc = IC.empty
143	fun empty () = Working (emptyIc ())
144
145	val currentComputation = ref (empty ())
146
147	fun clear () = currentComputation := empty ()
148
149	fun finishedComputation () =
150	case !currentComputation of
151	Working ic => let val c = IC.finish ic
152	in currentComputation := Finished c
153	; c
154	end
155	\| Finished c => c
156	val computation = finishedComputation
157
158	fun history () = Computation.output (finishedComputation (),
159	Out.error)
160	fun calls () = Computation.outputCalls (finishedComputation (),
161	Out.error)
162	fun times () = Computation.outputTimes (finishedComputation (),
163	Out.error)
164	fun inspect () = Computation.inspect (finishedComputation ())
165
166	fun ic () =
167	case !currentComputation of
168	Finished _ => let val ic = emptyIc ()
169	in currentComputation := Working ic
170	; ic
171	end
172	\| Working ic => ic
173
174	fun delayedCall (name, layoutArg, layoutAns) =
175	{call = fn () =>
176	let val comp = ic ()
177	val comp = if !Delayed.keepAll orelse not (IC.atTopLevel comp)
178	then comp
179	else (clear (); ic ())
180	in IC.call (comp, name, layoutArg)
181	end,
182	raisee = fn (t, _) => IC.raisee (ic (), t),
183	return = fn (ans, t) => IC.return (ic (),
184	fn () => layoutAns ans,
185	t)}
186
187	(---------------------------------------------------)
188	(* Immediate Feedback *)
189	(---------------------------------------------------)
190
191	structure Immediate =
192	struct
193	open Immediate
194
195	datatype debug =
196	None
197	\| Terminal
198	\| Out of Out.t
199
200	val debug = ref None
201
202	val showTime = ref false
203
204	val indentation: int ref = ref 0
205	val space: int = 3
206	fun left () = indentation := !indentation - space
207	fun right () = indentation := !indentation + space
208
209	val inChild = ref false
210	fun inChildProcess () = (inChild := true; indentation := 0)
211
212	fun message (l: Layout.t): unit =
213	case !debug of
214	None => ()
215	\| _ =>
216	let
217	val (out, done) =
218	case !debug of
219	Terminal => (Out.openOut "/dev/tty", Out.close)
220	\| Out out => (out, Out.flush)
221	\| _ => Error.bug "Trace.message"
222	open Layout
223	in output (seq [if !inChild
224	then seq [Pid.layout (Pid.current ()), str ": "]
225	else empty,
226	if !showTime
227	then str (Date.fmt
228	(Date.now (), "%b %d %H:%M:%S "))
229	else empty,
230	indent (l, !indentation)],
231	out)
232	; Out.newline out
233	; done out
234	end
235
236	fun finish (t, res) =
237	(left ()
238	; message (let open Layout
239	in case t of
240	NONE => seq [str "==> ", res]
241	\| SOME t =>
242	align [seq [str "==> time = ", Timer.layout t],
243	res]
244	end))
245
246	fun call (name, outArg, layoutAns) =
247	let
248	open Layout
249	fun call () = (message (seq [str name, str " ==> ",
250	outArg ()
251	handle e =>
252	seq [str "layout argument error: ",
253	Exn.layout e]])
254	; right ())
255	fun raisee (t, e) = finish (t, seq [str "raise: ", Exn.layout e])
256	fun return (ans, t) =
257	finish (t,
258	layoutAns ans
259	handle e => seq [str "layout answer error: ",
260	Exn.layout e])
261	in {call = call,
262	raisee = raisee,
263	return = return}
264	end
265
266	val message =
267	fn l =>
268	(left ()
269	; indentation := 1 + !indentation
270	; message l
271	; indentation := !indentation - 1
272	; right ())
273
274	val messageStr = message o Layout.str
275	end
276
277	(---------------------------------------------------)
278	(* Instrumentation *)
279	(---------------------------------------------------)
280
281	type info = {name: string, flags: flags}
282
283	val bogusInfo = {name = "bogus", flags = {delayed = ref false,
284	immediate = ref false,
285	time = ref false}}
286
287	val shouldTrace = Assert.debug
288
289	fun info name =
290	if shouldTrace
291	then {name = name, flags = StringMap.lookup (map, name)}
292	else bogusInfo
293
294	fun traceInfo ({name, flags = {immediate, delayed, time}},
295	layoutArg, layoutAns, check) f a =
296	if not shouldTrace
297	then f a
298	else
299	let
300	val immediate = Immediate.isOn immediate
301	val delayed = Delayed.isOn delayed
302	val time = Time.isOn time
303	in
304	if not (immediate orelse delayed orelse time orelse Assert.debug)
305	then f a
306	else let val outArg = fn () => layoutArg a
307	val noCall = {call = fn _ => (),
308	raisee = fn _ => (),
309	return = fn _ => ()}
310	val immed = if immediate
311	then Immediate.call (name, outArg, layoutAns)
312	else noCall
313	val delay = if delayed
314	then delayedCall (name, outArg, layoutAns)
315	else noCall
316	val _ = (#call delay ()
317	; #call immed ())
318	val check =
319	if Assert.debug
320	then let val (b, check) = check a
321	val _ = Assert.assert (concat [name, " argument"],
322	fn () => b)
323	in check
324	end
325	else fn _ => true
326	val startTime = if time then SOME (Timer.times ()) else NONE
327	fun getTime () =
328	case startTime of
329	NONE => NONE
330	\| SOME {self = {utime = u, stime = s}, ...} =>
331	SOME (let val {self = {utime = u', stime = s'},
332	...} = Timer.times ()
333	in Timer.+ (Timer.- (u', u),
334	Timer.- (s', s))
335	end)
336	val ans = f a handle exn => let val t = getTime ()
337	in #raisee delay (t, exn)
338	; #raisee immed (t, exn)
339	; raise exn
340	end
341	val t = getTime ()
342	in #return delay (ans, t)
343	; #return immed (ans, t)
344	; Assert.assert (concat [name, " result"], fn () => check ans)
345	; ans
346	end
347	end
348
349	fun assertTrue _ = (true, fn _ => true)
350
351	fun traceInfo' (info, layoutArg, layoutAns) =
352	traceInfo (info, layoutArg, layoutAns, assertTrue)
353
354	fun traceAssert (name, layoutArg, layoutAns, check) =
355	traceInfo (info name, layoutArg, layoutAns, check)
356
357	fun trace (name, layoutArg, layoutAns) =
358	traceAssert (name, layoutArg, layoutAns, assertTrue)
359
360	fun ignore _ = Layout.empty
361
362	fun traceCall s = trace (s, ignore, ignore)
363
364	fun traceRec info =
365	let val trace = trace info
366	in fn f => let fun fix f a = trace (f (fix f)) a
367	in fix f
368	end
369	end
370
371	fun trace0 (name, layoutAns) =
372	trace (name, Unit.layout, layoutAns)
373
374	fun trace2 (name, layout1, layout2, layoutAns) =
375	trace (name, Layout.tuple2 (layout1, layout2), layoutAns)
376
377	fun trace3 (name, out1, out2, out3, outAns) =
378	trace (name, Layout.tuple3 (out1, out2, out3), outAns)
379
380	fun trace4 (name, out1, out2, out3, out4, outAns) =
381	trace (name, Layout.tuple4 (out1, out2, out3, out4), outAns)
382
383	fun trace5 (name, out1, out2, out3, out4, out5, outAns) =
384	trace (name, Layout.tuple5 (out1, out2, out3, out4, out5), outAns)
385
386	end
387
388	structure Computation = Trace.Computation