1 (* Copyright (C
) 2009 Matthew Fluet
.
2 * Copyright (C
) 1999-2006 Henry Cejtin
, Matthew Fluet
, Suresh
3 * Jagannathan
, and Stephen Weeks
.
5 * MLton is released under a BSD
-style license
.
6 * See the file MLton
-LICENSE for details
.
9 functor TraceControl (structure StringMap
: STRING_MAP
10 datatype status
= Always | Flagged | Never
12 val map
: flags StringMap
.t
13 val getFlag
: flags
-> bool ref
18 val status
= ref status
20 fun always () = status
:= Always
21 fun flagged () = status
:= Flagged
22 fun never () = status
:= Never
32 fun flag name
= getFlag (StringMap
.lookup (map
, name
))
34 fun whats
b () = StringMap
.keepAll (map
, fn flags
=> b
= !(getFlag flags
))
36 val whatsOn
= whats
true
37 val whatsOff
= whats
false
40 StringMap
.foreach (map
, fn flags
=> getFlag flags
:= b
)
45 fun some b ss
= List.foreach (ss
, fn s
=> flag s
:= b
)
52 (*-------------------------------------------------------------------*)
54 (*-------------------------------------------------------------------*)
56 structure Trace
: TRACE
=
59 structure IC
= IntermediateComputation
60 structure Timer
= Time
62 val immediateDefault
= ref
false
63 val delayedDefault
= ref
false
64 val timeDefault
= ref
false
66 type flags
= {immediate
: bool ref
,
70 val map
= StringMap
.new (fn () => {immediate
= ref (!immediateDefault
),
71 delayed
= ref (!delayedDefault
),
72 time
= ref (!timeDefault
)})
74 fun traceable () = StringMap
.domain map
76 fun outputTraceable () =
77 Layout
.output (List.layout Layout
.str (traceable ()),
80 datatype status
= Always | Flagged | Never
83 TraceControl (type flags
= flags
85 structure StringMap
= StringMap
86 datatype status
= datatype status
87 fun getFlag ({immediate
, ...}: flags
) = immediate
88 val default
= immediateDefault
93 TraceControl (type flags
= flags
95 structure StringMap
= StringMap
96 datatype status
= datatype status
97 fun getFlag ({delayed
, ...}: flags
) = delayed
98 val default
= delayedDefault
102 val keepAll
= ref
true
106 TraceControl (type flags
= flags
108 structure StringMap
= StringMap
109 datatype status
= datatype status
110 fun getFlag ({time
, ...}: flags
) = time
111 val default
= timeDefault
114 fun never () = (Immediate
.never ()
118 fun always () = (Immediate
.always ()
122 fun flagged () = (Immediate
.flagged ()
127 StringMap
.foreach (map
, fn {immediate
, delayed
, time
} =>
132 (*---------------------------------------------------*)
133 (* Delayed Feedback
*)
134 (*---------------------------------------------------*)
136 structure Computation
= IC
.Computation
140 | Finished
of Computation
.t
142 val emptyIc
= IC
.empty
143 fun empty () = Working (emptyIc ())
145 val currentComputation
= ref (empty ())
147 fun clear () = currentComputation
:= empty ()
149 fun finishedComputation () =
150 case !currentComputation
of
151 Working ic
=> let val c
= IC
.finish ic
152 in currentComputation
:= Finished c
156 val computation
= finishedComputation
158 fun history () = Computation
.output (finishedComputation (),
160 fun calls () = Computation
.outputCalls (finishedComputation (),
162 fun times () = Computation
.outputTimes (finishedComputation (),
164 fun inspect () = Computation
.inspect (finishedComputation ())
167 case !currentComputation
of
168 Finished _
=> let val ic
= emptyIc ()
169 in currentComputation
:= Working ic
174 fun delayedCall (name
, layoutArg
, layoutAns
) =
177 val comp
= if !Delayed
.keepAll
orelse not (IC
.atTopLevel comp
)
179 else (clear (); ic ())
180 in IC
.call (comp
, name
, layoutArg
)
182 raisee
= fn (t
, _
) => IC
.raisee (ic (), t
),
183 return
= fn (ans
, t
) => IC
.return (ic (),
184 fn () => layoutAns ans
,
187 (*---------------------------------------------------*)
188 (* Immediate Feedback
*)
189 (*---------------------------------------------------*)
191 structure Immediate
=
202 val showTime
= ref
false
204 val indentation
: int ref
= ref
0
206 fun left () = indentation
:= !indentation
- space
207 fun right () = indentation
:= !indentation
+ space
209 val inChild
= ref
false
210 fun inChildProcess () = (inChild
:= true; indentation
:= 0)
212 fun message (l
: Layout
.t
): unit
=
219 Terminal
=> (Out
.openOut
"/dev/tty", Out
.close
)
220 | Out out
=> (out
, Out
.flush
)
221 | _
=> Error
.bug
"Trace.message"
223 in output (seq
[if !inChild
224 then seq
[Pid
.layout (Pid
.current ()), str
": "]
228 (Date
.now (), "%b %d %H:%M:%S "))
230 indent (l
, !indentation
)],
236 fun finish (t
, res
) =
238 ; message (let open Layout
240 NONE
=> seq
[str
"==> ", res
]
242 align
[seq
[str
"==> time = ", Timer
.layout t
],
246 fun call (name
, outArg
, layoutAns
) =
249 fun call () = (message (seq
[str name
, str
" ==> ",
252 seq
[str
"layout argument error: ",
255 fun raisee (t
, e
) = finish (t
, seq
[str
"raise: ", Exn
.layout e
])
256 fun return (ans
, t
) =
259 handle e
=> seq
[str
"layout answer error: ",
269 ; indentation
:= 1 + !indentation
271 ; indentation
:= !indentation
- 1
274 val messageStr
= message
o Layout
.str
277 (*---------------------------------------------------*)
278 (* Instrumentation
*)
279 (*---------------------------------------------------*)
281 type info
= {name
: string, flags
: flags
}
283 val bogusInfo
= {name
= "bogus", flags
= {delayed
= ref
false,
284 immediate
= ref
false,
287 val shouldTrace
= Assert
.debug
291 then {name
= name
, flags
= StringMap
.lookup (map
, name
)}
294 fun traceInfo ({name
, flags
= {immediate
, delayed
, time
}},
295 layoutArg
, layoutAns
, check
) f a
=
300 val immediate
= Immediate
.isOn immediate
301 val delayed
= Delayed
.isOn delayed
302 val time
= Time
.isOn time
304 if not (immediate
orelse delayed
orelse time
orelse Assert
.debug
)
306 else let val outArg
= fn () => layoutArg a
307 val noCall
= {call
= fn _
=> (),
310 val immed
= if immediate
311 then Immediate
.call (name
, outArg
, layoutAns
)
313 val delay
= if delayed
314 then delayedCall (name
, outArg
, layoutAns
)
316 val _
= (#call
delay ()
320 then let val (b
, check
) = check a
321 val _
= Assert
.assert (concat
[name
, " argument"],
326 val startTime
= if time
then SOME (Timer
.times ()) else 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
),
336 val ans
= f a
handle exn
=> let val t
= getTime ()
337 in #raisee
delay (t
, exn
)
338 ; #raisee
immed (t
, exn
)
342 in #return
delay (ans
, t
)
343 ; #return
immed (ans
, t
)
344 ; Assert
.assert (concat
[name
, " result"], fn () => check ans
)
349 fun assertTrue _
= (true, fn _
=> true)
351 fun traceInfo
' (info
, layoutArg
, layoutAns
) =
352 traceInfo (info
, layoutArg
, layoutAns
, assertTrue
)
354 fun traceAssert (name
, layoutArg
, layoutAns
, check
) =
355 traceInfo (info name
, layoutArg
, layoutAns
, check
)
357 fun trace (name
, layoutArg
, layoutAns
) =
358 traceAssert (name
, layoutArg
, layoutAns
, assertTrue
)
360 fun ignore _
= Layout
.empty
362 fun traceCall s
= trace (s
, ignore
, ignore
)
365 let val trace
= trace info
366 in fn f
=> let fun fix f a
= trace (f (fix f
)) a
371 fun trace0 (name
, layoutAns
) =
372 trace (name
, Unit
.layout
, layoutAns
)
374 fun trace2 (name
, layout1
, layout2
, layoutAns
) =
375 trace (name
, Layout
.tuple2 (layout1
, layout2
), layoutAns
)
377 fun trace3 (name
, out1
, out2
, out3
, outAns
) =
378 trace (name
, Layout
.tuple3 (out1
, out2
, out3
), outAns
)
380 fun trace4 (name
, out1
, out2
, out3
, out4
, outAns
) =
381 trace (name
, Layout
.tuple4 (out1
, out2
, out3
, out4
), outAns
)
383 fun trace5 (name
, out1
, out2
, out3
, out4
, out5
, outAns
) =
384 trace (name
, Layout
.tuple5 (out1
, out2
, out3
, out4
, out5
), outAns
)
388 structure Computation
= Trace
.Computation