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/compiler/DebugProf/profile/btimp.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/DebugProf/profile/btimp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 903 - (view) (download)

1 : blume 903 (*
2 :     * (Sample) Implementation of a plug-in module for back-tracing.
3 :     * This module hooks itself into the core environment so that
4 :     * btrace-annotated (see btrace.sml) code will invoke the provided
5 :     * functions "add", "push", "save", and "report".
6 :     *
7 :     * This module keeps track of the dynamic call-chain of annotated modules
8 :     * (those that were compiled with SMLofNJ.Internals.BTrace.mode set to true).
9 :     * Non-tail calls are maintained in a stack-like fashion, and in addition
10 :     * to this the module will also track tail-calls so that a sequence of
11 :     * GOTO-like jumps from loop-cluster to loop-cluster can be shown.
12 :     *
13 :     * This strategy, while certainly costly, has no more than constant-factor
14 :     * overhead in space and time and will keep tail-recursive code tail-recursive.
15 :     *
16 :     * Copyright (c) 2000 by Lucent Bell Laboratories
17 :     *
18 :     * author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
19 :     *)
20 :     structure BTImp : sig
21 :     end = struct
22 :    
23 :     structure M = IntRedBlackMap
24 :    
25 :     (* Home-cooked set representation:
26 :     * This relies on two things:
27 :     * - we don't need a lookup operation
28 :     * - we only join sets that are known to be disjoint *)
29 :     datatype set =
30 :     EMPTY
31 :     | SINGLETON of int
32 :     | UNION of set * set
33 :    
34 :     fun fold f i EMPTY = i
35 :     | fold f i (SINGLETON x) = f (x, i)
36 :     | fold f i (UNION (x, y)) = fold f (fold f i y) x
37 :    
38 :     datatype descr =
39 :     STEP of int
40 :     | LOOP of set
41 :    
42 :     type stage = { num: int, from: int, descr: descr }
43 :    
44 :     type frame = { depth: int, map: int M.map, stages: stage list }
45 :    
46 :     type history = frame * frame list
47 :    
48 :     datatype state =
49 :     NORMAL of history
50 :     | PENDING of int * history
51 :    
52 :     val cur : state ref =
53 :     ref (NORMAL ({ depth = 0, map = M.empty, stages = [] }, []))
54 :    
55 :     val names = ref (M.empty: string M.map)
56 :     val next = ref 0
57 :    
58 :     fun reset () = (names := M.empty; next := 0)
59 :    
60 :     fun reserve n = !next before next := !next + n
61 :    
62 :     fun register (module, fct, s) =
63 :     names := M.insert (!names, module + fct, s)
64 :    
65 :     fun add (module, fct) = let
66 :     val i = module + fct
67 :     val (from, front, back) =
68 :     case !cur of
69 :     PENDING (from, (front, back)) => (from, front, back)
70 :     | NORMAL (front, back) => (~1, front, back)
71 :     val { depth, map, stages } = front
72 :     in
73 :     case M.find (map, i) of
74 :     SOME num => let
75 :     fun toSet (STEP i) = SINGLETON i
76 :     | toSet (LOOP s) = s
77 :     fun join (set, d) = UNION (set, toSet d)
78 :     fun finish (stages, from, c, EMPTY) =
79 :     let val stage = { num = num, from = from,
80 :     descr = LOOP (toSet c) }
81 :     val front' = { depth = depth,
82 :     map = map,
83 :     stages = stage :: stages }
84 :     in
85 :     cur := NORMAL (front', back)
86 :     end
87 :     | finish (stages, from, c, set) =
88 :     let val stage = { num = num, from = from,
89 :     descr = LOOP (join (set, c)) }
90 :     fun ins (i, m) = M.insert (m, i, num)
91 :     val front' = { depth = depth,
92 :     map = fold ins map set,
93 :     stages = stage :: stages }
94 :     in
95 :     cur := NORMAL (front', back)
96 :     end
97 :     fun loop ([], set) = () (* cannot happen! *)
98 :     | loop ({ num = n', from, descr = d' } :: t, set) =
99 :     if num = n' then finish (t, from, d', set)
100 :     else loop (t, join (set, d'))
101 :     in
102 :     loop (stages, EMPTY)
103 :     end
104 :     | NONE => let
105 :     val num = case stages of
106 :     [] => 0
107 :     | s0 :: _ => #num s0 + 1
108 :     val stage = { num = num, from = from, descr = STEP i}
109 :     val front' = { depth = depth,
110 :     map = M.insert (map, i, num),
111 :     stages = stage :: stages }
112 :     in
113 :     cur := NORMAL (front' , back)
114 :     end
115 :     end
116 :    
117 :     fun push (module, loc) = let
118 :     val id = module + loc
119 :     val (NORMAL old | PENDING (_, old)) = !cur
120 :     val (front, _) = old
121 :     val front' = { depth = #depth front + 1, map = M.empty, stages = [] }
122 :     in
123 :     cur := PENDING (id, (front', op :: old));
124 :     fn () => cur := NORMAL old
125 :     end
126 :    
127 :     fun nopush (module, loc) = let
128 :     val id = module + loc
129 :     val (NORMAL old | PENDING (_, old)) = !cur
130 :     in
131 :     cur := PENDING (id, old)
132 :     end
133 :    
134 :     fun save () = let
135 :     val old = !cur
136 :     in
137 :     fn () => cur := old
138 :     end
139 :    
140 :     fun report () = let
141 :     val (NORMAL top | PENDING (_, top)) = !cur
142 :     val (front, back) = top
143 :     fun do_report () = let
144 :     val (NORMAL bot | PENDING (_, bot)) = !cur
145 :     val (front', _) = bot
146 :     val bot_depth = #depth front'
147 :     fun isBot (f: frame) = #depth f = bot_depth
148 :     fun name (w, pad, from, i) = let
149 :     fun find x = getOpt (M.find (!names, x), "???")
150 :     val n = find i
151 :     val tail = case from of
152 :     NONE => ["\n"]
153 :     | SOME j => ["\n (from: ", find j, ")\n"]
154 :     in
155 :     concat (w :: pad :: " " :: n :: tail)
156 :     end
157 :     fun stage (w, { num, from, descr = STEP i }, a) =
158 :     name (w, " ", SOME from, i) :: a
159 :     | stage (w, { num, from, descr = LOOP s }, a) = let
160 :     fun loop ([], a) = a
161 :     | loop ([i], a) = name (w, "-\\", SOME from, i) :: a
162 :     | loop (h :: t, a) =
163 :     loop (t, name (" ", " |", NONE, h) :: a)
164 :     fun start ([], a) = a
165 :     | start ([i], a) = name (w, "-(", SOME from, i) :: a
166 :     | start (h :: t, a) =
167 :     loop (t, name (" ", " /", NONE, h) :: a)
168 :     in
169 :     start (fold (op ::) [] s, a)
170 :     end
171 :     fun jumps ([], a) = a
172 :     | jumps ([n], a) = stage ("CALL", n, a)
173 :     | jumps (h :: t, a) = jumps (t, stage ("GOTO", h, a))
174 :     fun calls (h, [], a) = jumps (#stages h, a)
175 :     | calls (h, h' :: t, a) = let
176 :     val a = jumps (#stages h, a)
177 :     in
178 :     if isBot h then a else calls (h', t, a)
179 :     end
180 :     in
181 :     rev (calls (front, back, []))
182 :     end
183 :     in
184 :     do_report
185 :     end
186 :    
187 :     fun install () =
188 :     SMLofNJ.Internals.BTrace.install
189 :     { corefns = { save = save,
190 :     push = push,
191 :     nopush = nopush,
192 :     add = add,
193 :     reserve = reserve,
194 :     register = register,
195 :     report = report },
196 :     reset = reset }
197 :    
198 :     val _ = install ()
199 :     end

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