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 /sml/trunk/src/smlnj-lib/TraceDebugProf/back-trace.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-lib/TraceDebugProf/back-trace.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1653 - (view) (download)

1 : mblume 1653 (* 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 :     exception BTraceTriggered of unit -> string list
22 :     val trigger : unit -> 'a
23 :     val monitor : (unit -> unit) -> unit
24 :     val install : unit -> unit
25 :     end = struct
26 :    
27 :     structure M = IntRedBlackMap
28 :    
29 :     (* Home-cooked set representation:
30 :     * This relies on two things:
31 :     * - we don't need a lookup operation
32 :     * - we only join sets that are known to be disjoint *)
33 :     datatype set =
34 :     EMPTY
35 :     | SINGLETON of int
36 :     | UNION of set * set
37 :    
38 :     fun fold f i EMPTY = i
39 :     | fold f i (SINGLETON x) = f (x, i)
40 :     | fold f i (UNION (x, y)) = fold f (fold f i y) x
41 :    
42 :     datatype descr =
43 :     STEP of int
44 :     | LOOP of set
45 :    
46 :     type stage = { num: int, from: int, descr: descr }
47 :    
48 :     type frame = { depth: int, map: int M.map, stages: stage list }
49 :    
50 :     type history = frame * frame list
51 :    
52 :     datatype state =
53 :     NORMAL of history
54 :     | PENDING of int * history
55 :    
56 :     val cur : state ref =
57 :     ref (NORMAL ({ depth = 0, map = M.empty, stages = [] }, []))
58 :    
59 :     val names = ref (M.empty: string M.map)
60 :    
61 :     fun register (module, _: int, id, s) =
62 :     names := M.insert (!names, module + id, s)
63 :    
64 :     fun enter (module, fct) = let
65 :     val i = module + fct
66 :     val (from, front, back) =
67 :     case !cur of
68 :     PENDING (from, (front, back)) => (from, front, back)
69 :     | NORMAL (front, back) => (~1, front, back)
70 :     val { depth, map, stages } = front
71 :     in
72 :     case M.find (map, i) of
73 :     SOME num => let
74 :     fun toSet (STEP i) = SINGLETON i
75 :     | toSet (LOOP s) = s
76 :     fun join (set, d) = UNION (set, toSet d)
77 :     fun finish (stages, from, c, EMPTY) =
78 :     let val stage = { num = num, from = from,
79 :     descr = LOOP (toSet c) }
80 :     val front' = { depth = depth,
81 :     map = map,
82 :     stages = stage :: stages }
83 :     in
84 :     cur := NORMAL (front', back)
85 :     end
86 :     | finish (stages, from, c, set) =
87 :     let val stage = { num = num, from = from,
88 :     descr = LOOP (join (set, c)) }
89 :     fun ins (i, m) = M.insert (m, i, num)
90 :     val front' = { depth = depth,
91 :     map = fold ins map set,
92 :     stages = stage :: stages }
93 :     in
94 :     cur := NORMAL (front', back)
95 :     end
96 :     fun loop ([], set) = () (* cannot happen! *)
97 :     | loop ({ num = n', from, descr = d' } :: t, set) =
98 :     if num = n' then finish (t, from, d', set)
99 :     else loop (t, join (set, d'))
100 :     in
101 :     loop (stages, EMPTY)
102 :     end
103 :     | NONE => let
104 :     val num = case stages of
105 :     [] => 0
106 :     | s0 :: _ => #num s0 + 1
107 :     val stage = { num = num, from = from, descr = STEP i}
108 :     val front' = { depth = depth,
109 :     map = M.insert (map, i, num),
110 :     stages = stage :: stages }
111 :     in
112 :     cur := NORMAL (front' , back)
113 :     end
114 :     end
115 :    
116 :     fun push (module, loc) = let
117 :     val id = module + loc
118 :     val (NORMAL old | PENDING (_, old)) = !cur
119 :     val (front, _) = old
120 :     val front' = { depth = #depth front + 1, map = M.empty, stages = [] }
121 :     in
122 :     cur := PENDING (id, (front', op :: old));
123 :     fn () => cur := NORMAL old
124 :     end
125 :    
126 :     fun nopush (module, loc) = let
127 :     val id = module + loc
128 :     val (NORMAL old | PENDING (_, old)) = !cur
129 :     in
130 :     cur := PENDING (id, old)
131 :     end
132 :    
133 :     fun save () = let
134 :     val old = !cur
135 :     in
136 :     fn () => cur := old
137 :     end
138 :    
139 :     fun report () = let
140 :     val (NORMAL top | PENDING (_, top)) = !cur
141 :     val (front, back) = top
142 :     fun do_report () = let
143 :     val (NORMAL bot | PENDING (_, bot)) = !cur
144 :     val (front', _) = bot
145 :     val bot_depth = #depth front'
146 :     fun isBot (f: frame) = #depth f = bot_depth
147 :     fun name (w, pad, from, i) = let
148 :     fun find x = getOpt (M.find (!names, x), "???")
149 :     val n = find i
150 :     val tail = case from of
151 :     NONE => ["\n"]
152 :     | SOME j => ["\n (from: ", find j, ")\n"]
153 :     in
154 :     concat (w :: pad :: " " :: n :: tail)
155 :     end
156 :     fun stage (w, { num, from, descr = STEP i }, a) =
157 :     name (w, " ", SOME from, i) :: a
158 :     | stage (w, { num, from, descr = LOOP s }, a) = let
159 :     fun loop ([], a) = a
160 :     | loop ([i], a) = name (w, "-\\", SOME from, i) :: a
161 :     | loop (h :: t, a) =
162 :     loop (t, name (" ", " |", NONE, h) :: a)
163 :     fun start ([], a) = a
164 :     | start ([i], a) = name (w, "-(", SOME from, i) :: a
165 :     | start (h :: t, a) =
166 :     loop (t, name (" ", " /", NONE, h) :: a)
167 :     in
168 :     start (fold (op ::) [] s, a)
169 :     end
170 :     fun jumps ([], a) = a
171 :     | jumps ([n], a) = stage ("CALL", n, a)
172 :     | jumps (h :: t, a) = jumps (t, stage ("GOTO", h, a))
173 :     fun calls (h, [], a) = jumps (#stages h, a)
174 :     | calls (h, h' :: t, a) = let
175 :     val a = jumps (#stages h, a)
176 :     in
177 :     if isBot h then a else calls (h', t, a)
178 :     end
179 :     in
180 :     rev (calls (front, back, []))
181 :     end
182 :     in
183 :     do_report
184 :     end
185 :    
186 :     exception BTraceTriggered of unit -> string list
187 :    
188 :     fun monitor work =
189 :     let val restore = save ()
190 :     fun hdl (e, []) = raise e
191 :     | hdl (e, hist) =
192 :     (Control.Print.say
193 :     (concat ("\n*** BACK-TRACE ***\n" :: hist));
194 :     Control.Print.say "\n";
195 :     raise e)
196 :     in
197 :     work ()
198 :     handle e as BTraceTriggered do_report =>
199 :     (restore ();
200 :     hdl (e, do_report ()))
201 :     | e =>
202 :     let val do_report = report ()
203 :     in
204 :     restore ();
205 :     hdl (e, do_report ())
206 :     end
207 :     end
208 :    
209 :     val name = "btrace"
210 :    
211 :     fun install () =
212 :     let val plugin = { name = name, save = save,
213 :     push = push, nopush = nopush,
214 :     enter = enter, register = register }
215 :     val monitor = { name = name, monitor = monitor }
216 :     fun addto r x = r := x :: !r
217 :     in
218 :     addto SMLofNJ.Internals.TDP.active_plugins plugin;
219 :     addto SMLofNJ.Internals.TDP.active_monitors monitor
220 :     end
221 :    
222 :     fun trigger () = raise BTraceTriggered (report ())
223 :     end

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