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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 675 - (view) (download)

1 : blume 675 (*
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 :     exception NotFound
24 :    
25 :     structure HT = IntHashTable
26 :     structure IS = IntRedBlackSet
27 :     structure IM = IntRedBlackMap
28 :     structure SM = RedBlackMapFn (struct
29 :     type ord_key = string val compare = String.compare
30 :     end)
31 :    
32 :     type intset = IS.set
33 :    
34 :     datatype contents =
35 :     SINGLE of int
36 :     | CLUSTER of intset
37 :    
38 :     type stamp = unit ref
39 :    
40 :     type node = stamp * contents
41 :    
42 :     type htable = node HT.hash_table
43 :    
44 :     type stage = htable * node list ref
45 :    
46 :     type history = stage list
47 :    
48 :     val s2i_m = ref (SM.empty: int SM.map)
49 :     val i2s_m = ref (IM.empty: string IM.map)
50 :     val next = ref 0
51 :    
52 :     fun reset () = (s2i_m := SM.empty; i2s_m := IM.empty; next := 0)
53 :    
54 :     fun mkid s =
55 :     case SM.find (!s2i_m, s) of
56 :     SOME i => i
57 :     | NONE => let
58 :     val i = !next
59 :     in
60 :     next := i + 1;
61 :     s2i_m := SM.insert (!s2i_m, s, i);
62 :     i
63 :     end
64 :    
65 :     fun register (i, s) = let
66 :     fun insert () = i2s_m := IM.insert (!i2s_m, i, s)
67 :     in
68 :     case IM.find (!i2s_m, i) of
69 :     NONE => insert ()
70 :     | SOME s' =>
71 :     if s = s' then ()
72 :     else (print (concat ["BTrace: register: id clash between\n\t", s',
73 :     "\nand\n\t", s, ";\nusing latter.\n"]);
74 :     insert ())
75 :     end
76 :    
77 :     fun new_ht () = HT.mkTable (16, NotFound)
78 :    
79 :     val cur = ref ([]: history)
80 :    
81 :     fun add i =
82 :     case !cur of
83 :     [] => ()
84 :     | (ht, nlr) :: _ =>
85 :     (case HT.find ht i of
86 :     SOME (s, c) => let
87 :     fun toSet (SINGLE i) = IS.singleton i
88 :     | toSet (CLUSTER s) = s
89 :     fun join (set, c) = IS.union (set, toSet c)
90 :     fun finish (l, set) = let
91 :     val n = (s, CLUSTER set)
92 :     in
93 :     nlr := n :: l;
94 :     IS.app (fn i => HT.insert ht (i, n)) set
95 :     end
96 :     fun loop ([], set) = finish ([], set)
97 :     | loop ((s', c) :: t, set) =
98 :     if s = s' then finish (t, set)
99 :     else loop (t, join (set, c))
100 :     in
101 :     loop (!nlr, toSet c)
102 :     end
103 :     | NONE => let
104 :     val n = (ref (), SINGLE i)
105 :     val l = n :: !nlr
106 :     in
107 :     HT.insert ht (i, n);
108 :     nlr := l
109 :     end)
110 :    
111 :     fun push () = let
112 :     val old = !cur
113 :     in
114 :     cur := (new_ht (), ref []) :: old;
115 :     fn () => cur := old
116 :     end
117 :    
118 :     fun save () = let
119 :     val old = !cur
120 :     in
121 :     fn () => cur := old
122 :     end
123 :    
124 :     fun report () = let
125 :     val top = !cur
126 :     fun do_report () = let
127 :     val bot = !cur
128 :     val isBot =
129 :     case bot of
130 :     [] => (fn _ => false)
131 :     | (_, bot_nlr) :: _ => (fn nlr => bot_nlr = nlr)
132 :     fun name (what, pad, i) = let
133 :     val n = case IM.find (!i2s_m, i) of
134 :     NONE => "???"
135 :     | SOME s => s
136 :     in
137 :     concat [what, pad, " ", n, "\n"]
138 :     end
139 :     fun node (what, (_, SINGLE i), a) = name (what, " ", i) :: a
140 :     | node (what, (_, CLUSTER s), a) = let
141 :     fun loop ([], a) = a
142 :     | loop ([i], a) = name (what, "-\\", i) :: a
143 :     | loop (h :: t, a) =
144 :     loop (t, name (" ", " |", h) :: a)
145 :     fun looph ([], a) = a
146 :     | looph ([i], a) = name (what, "-(", i) :: a
147 :     | looph (h :: t, a) =
148 :     loop (t, name (" ", " /", h) :: a)
149 :     in
150 :     looph (IS.listItems s, a)
151 :     end
152 :     fun jumps ([], a) = a
153 :     | jumps ([n], a) = node ("CALL", n, a)
154 :     | jumps (h :: t, a) = jumps (t, node ("GOTO", h, a))
155 :     fun calls ([], a) = a
156 :     | calls ((_, nlr as ref nl) :: t, a) = let
157 :     val a = jumps (nl, a)
158 :     in
159 :     if isBot nlr then a else calls (t, a)
160 :     end
161 :     in
162 :     rev (calls (top, []))
163 :     end
164 :     in
165 :     do_report
166 :     end
167 :    
168 :     fun install () =
169 :     SMLofNJ.Internals.BTrace.install
170 :     { corefns = { save = save,
171 :     push = push,
172 :     add = add,
173 :     register = register,
174 :     report = report },
175 :     reset = reset,
176 :     mkid = mkid }
177 :    
178 :     val _ = install ()
179 :     end

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