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 /trace-debug-profile/releases/release-110.74/back-trace.sml
ViewVC logotype

Annotation of /trace-debug-profile/releases/release-110.74/back-trace.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3692 - (view) (download)

1 : mblume 1758 (* back-trace.sml
2 :     *
3 :     * A plug-in module for back-tracing. This module hooks itself into
4 :     * the core environment so that tdp-instrumented code will invoke the
5 :     * provided functions "enter", "push", "save", and "report".
6 :     *
7 :     * This module keeps track of the dynamic call-chain of instrumented modules.
8 :     * Non-tail calls are maintained in a stack-like fashion, and in addition
9 :     * to this the module will also track tail-calls so that a sequence of
10 :     * GOTO-like jumps from loop-cluster to loop-cluster can be shown.
11 :     *
12 :     * This strategy, while certainly costly, has no more than constant-factor
13 :     * overhead in space and time and will keep tail-recursive code
14 :     * tail-recursive.
15 :     *
16 :     * Copyright (c) 2004 by The Fellowship of SML/NJ
17 :     *
18 :     * Author: Matthias Blume (blume@tti-c.org)
19 :     *)
20 :     structure BackTrace : sig
21 :     val trigger : unit -> 'a
22 :     val monitor : (unit -> 'a) -> 'a
23 :     val install : unit -> unit
24 :     end = struct
25 :    
26 :     structure M = IntRedBlackMap
27 :    
28 :     (* Home-cooked set representation:
29 :     * This relies on two things:
30 :     * - we don't need a lookup operation
31 :     * - we only join sets that are known to be disjoint *)
32 :     datatype set =
33 :     EMPTY
34 :     | SINGLETON of int
35 :     | UNION of set * set
36 :    
37 :     fun fold f i EMPTY = i
38 :     | fold f i (SINGLETON x) = f (x, i)
39 :     | fold f i (UNION (x, y)) = fold f (fold f i y) x
40 :    
41 :     datatype descr =
42 :     STEP of int
43 :     | LOOP of set
44 :    
45 :     type stage = { num: int, from: int, descr: descr }
46 :    
47 :     type frame = { depth: int, map: int M.map, stages: stage list }
48 :    
49 :     type history = frame * frame list
50 :    
51 :     datatype state =
52 :     NORMAL of history
53 :     | PENDING of int * history
54 :    
55 :     val cur : state ref =
56 :     ref (NORMAL ({ depth = 0, map = M.empty, stages = [] }, []))
57 :    
58 :     val names = ref (M.empty: string M.map)
59 :    
60 :     fun register (module, _: int, id, s) =
61 :     names := M.insert (!names, module + id, s)
62 :    
63 :     fun enter (module, fct) = let
64 :     val i = module + fct
65 :     val (from, front, back) =
66 :     case !cur of
67 :     PENDING (from, (front, back)) => (from, front, back)
68 :     | NORMAL (front, back) => (~1, front, back)
69 :     val { depth, map, stages } = front
70 :     in
71 :     case M.find (map, i) of
72 :     SOME num => let
73 :     fun toSet (STEP i) = SINGLETON i
74 :     | toSet (LOOP s) = s
75 :     fun join (set, d) = UNION (set, toSet d)
76 :     fun finish (stages, from, c, EMPTY) =
77 :     let val stage = { num = num, from = from,
78 :     descr = LOOP (toSet c) }
79 :     val front' = { depth = depth,
80 :     map = map,
81 :     stages = stage :: stages }
82 :     in
83 :     cur := NORMAL (front', back)
84 :     end
85 :     | finish (stages, from, c, set) =
86 :     let val stage = { num = num, from = from,
87 :     descr = LOOP (join (set, c)) }
88 :     fun ins (i, m) = M.insert (m, i, num)
89 :     val front' = { depth = depth,
90 :     map = fold ins map set,
91 :     stages = stage :: stages }
92 :     in
93 :     cur := NORMAL (front', back)
94 :     end
95 :     fun loop ([], set) = () (* cannot happen! *)
96 :     | loop ({ num = n', from, descr = d' } :: t, set) =
97 :     if num = n' then finish (t, from, d', set)
98 :     else loop (t, join (set, d'))
99 :     in
100 :     loop (stages, EMPTY)
101 :     end
102 :     | NONE => let
103 :     val num = case stages of
104 :     [] => 0
105 :     | s0 :: _ => #num s0 + 1
106 :     val stage = { num = num, from = from, descr = STEP i}
107 :     val front' = { depth = depth,
108 :     map = M.insert (map, i, num),
109 :     stages = stage :: stages }
110 :     in
111 :     cur := NORMAL (front' , back)
112 :     end
113 :     end
114 :    
115 :     fun push (module, loc) = let
116 :     val id = module + loc
117 :     val (NORMAL old | PENDING (_, old)) = !cur
118 :     val (front, _) = old
119 :     val front' = { depth = #depth front + 1, map = M.empty, stages = [] }
120 :     in
121 :     cur := PENDING (id, (front', op :: old));
122 :     fn () => cur := NORMAL old
123 :     end
124 :    
125 :     fun nopush (module, loc) = let
126 :     val id = module + loc
127 :     val (NORMAL old | PENDING (_, old)) = !cur
128 :     in
129 :     cur := PENDING (id, old)
130 :     end
131 :    
132 :     fun save () = let
133 :     val old = !cur
134 :     in
135 :     fn () => cur := old
136 :     end
137 :    
138 :     fun report () = let
139 :     val (NORMAL top | PENDING (_, top)) = !cur
140 :     val (front, back) = top
141 :     fun do_report () = let
142 :     val (NORMAL bot | PENDING (_, bot)) = !cur
143 :     val (front', _) = bot
144 :     val bot_depth = #depth front'
145 :     fun isBot (f: frame) = #depth f = bot_depth
146 :     fun name (w, pad, from, i) = let
147 :     fun find x = getOpt (M.find (!names, x), "???")
148 :     val n = find i
149 :     val tail = case from of
150 :     NONE => ["\n"]
151 :     | SOME j => ["\n (from: ", find j, ")\n"]
152 :     in
153 :     concat (w :: pad :: " " :: n :: tail)
154 :     end
155 :     fun stage (w, { num, from, descr = STEP i }, a) =
156 :     name (w, " ", SOME from, i) :: a
157 :     | stage (w, { num, from, descr = LOOP s }, a) = let
158 :     fun loop ([], a) = a
159 :     | loop ([i], a) = name (w, "-\\", SOME from, i) :: a
160 :     | loop (h :: t, a) =
161 :     loop (t, name (" ", " |", NONE, h) :: a)
162 :     fun start ([], a) = a
163 :     | start ([i], a) = name (w, "-(", SOME from, i) :: a
164 :     | start (h :: t, a) =
165 :     loop (t, name (" ", " /", NONE, h) :: a)
166 :     in
167 :     start (fold (op ::) [] s, a)
168 :     end
169 :     fun jumps ([], a) = a
170 :     | jumps ([n], a) = stage ("CALL", n, a)
171 :     | jumps (h :: t, a) = jumps (t, stage ("GOTO", h, a))
172 :     fun calls (h, [], a) = jumps (#stages h, a)
173 :     | calls (h, h' :: t, a) = let
174 :     val a = jumps (#stages h, a)
175 :     in
176 :     if isBot h then a else calls (h', t, a)
177 :     end
178 :     in
179 :     rev (calls (front, back, []))
180 :     end
181 :     in
182 :     do_report
183 :     end
184 :    
185 :     exception BTraceTriggered of unit -> string list
186 :    
187 : mblume 1866 fun monitor0 (report_final_exn, work) =
188 : mblume 1758 let val restore = save ()
189 :     fun last (x, []) = x
190 :     | last (_, x :: xs) = last (x, xs)
191 :     fun emsg e =
192 :     case SMLofNJ.exnHistory e of
193 : mblume 1866 [] => General.exnMessage e
194 :     | (h :: t) =>
195 :     concat [last (h, t), ": ", General.exnMessage e]
196 : mblume 1758 fun hdl (e, []) =
197 : mblume 1866 (if report_final_exn then
198 :     Control.Print.say (emsg e ^ "\n\n")
199 :     else ();
200 : mblume 1758 raise e)
201 :     | hdl (e, hist) =
202 :     (Control.Print.say
203 :     (concat ("\n*** BACK-TRACE ***\n" :: hist));
204 : mblume 1866 if report_final_exn then
205 :     Control.Print.say (concat ["\n", emsg e, "\n\n"])
206 :     else ();
207 : mblume 1758 raise e)
208 :     in
209 :     work ()
210 :     handle e as BTraceTriggered do_report =>
211 :     (restore ();
212 :     hdl (e, do_report ()))
213 :     | e =>
214 :     let val do_report = report ()
215 :     in
216 :     restore ();
217 :     hdl (e, do_report ())
218 :     end
219 :     end
220 :    
221 : mblume 1866 fun monitor work = monitor0 (true, work)
222 :    
223 : mblume 1758 val name = "btrace"
224 :    
225 :     fun install () =
226 :     let val plugin = { name = name, save = save,
227 :     push = push, nopush = nopush,
228 :     enter = enter, register = register }
229 : mblume 1866 val monitor = { name = name, monitor = monitor0 }
230 : mblume 1758 fun addto r x = r := x :: !r
231 :     in
232 :     addto SMLofNJ.Internals.TDP.active_plugins plugin;
233 :     addto SMLofNJ.Internals.TDP.active_monitors monitor
234 :     end
235 :    
236 :     fun trigger () = raise BTraceTriggered (report ())
237 :     end

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