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/btrace.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 879 - (view) (download)

1 : blume 675 (*
2 :     * Perform Absyn annotations for back-tracing support.
3 :     * This adds a bt_add at the entry point of each FNexp,
4 :     * a push-restore sequence (bt_push) at each non-tail call site of
5 :     * a non-primitive function, and a save-restore sequence to each HANDLEexp.
6 :     *
7 :     * Copyright (c) 2000 by Lucent Bell Laboratories
8 :     *
9 :     * author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
10 :     *)
11 :     local
12 :     structure A = Absyn
13 :     structure SE = StaticEnv
14 :     structure SP = SymPath
15 :     structure EM = ErrorMsg
16 :     structure VC = VarCon
17 :     structure BT = BasicTypes
18 :     structure II = InlInfo
19 :     structure EU = ElabUtil
20 :    
21 :     structure Dummy = BTImp (* mention it, so it gets made! *)
22 :     in
23 :    
24 :     signature BTRACE = sig
25 : blume 879 val instrument : SE.staticEnv * CompInfo.compInfo -> A.dec -> A.dec
26 : blume 675 end
27 :    
28 :     structure BTrace :> BTRACE = struct
29 :    
30 : blume 677 exception NoCore
31 :    
32 : blume 675 fun impossible s = EM.impossible ("BTrace: " ^ s)
33 :    
34 :     infix -->
35 :     val op --> = BT.-->
36 :    
37 : blume 677 val i_i_Ty = BT.intTy --> BT.intTy
38 :     val ii_u_Ty = BT.tupleTy [BT.intTy, BT.intTy] --> BT.unitTy
39 : blume 679 val ii_u_u_Ty = ii_u_Ty --> BT.unitTy
40 : blume 675 val u_u_Ty = BT.unitTy --> BT.unitTy
41 :     val u_u_u_Ty = BT.unitTy --> u_u_Ty
42 : blume 677 val iis_u_Ty = BT.tupleTy [BT.intTy, BT.intTy, BT.unitTy] --> BT.unitTy
43 : blume 675
44 : blume 879 fun instrument0 (senv, cinfo: CompInfo.compInfo) d = let
45 : blume 675
46 :     val matchstring = #errorMatch cinfo
47 :    
48 :     val mkv = #mkLvar cinfo
49 :    
50 :     fun tmpvar (n, t) = let
51 :     val sy = Symbol.varSymbol n
52 :     in
53 :     VC.VALvar { access = Access.namedAcc (sy, mkv), info = II.nullInfo,
54 :     path = SP.SPATH [sy], typ = ref t }
55 :     end
56 :    
57 :     val isSpecial = let
58 :     val l = [SpecialSymbols.paramId,
59 :     SpecialSymbols.functorId,
60 :     SpecialSymbols.hiddenId,
61 :     SpecialSymbols.tempStrId,
62 :     SpecialSymbols.tempFctId,
63 :     SpecialSymbols.fctbodyId,
64 :     SpecialSymbols.anonfsigId,
65 :     SpecialSymbols.resultId,
66 :     SpecialSymbols.returnId,
67 :     SpecialSymbols.internalVarId]
68 :     in
69 :     fn s => List.exists (fn s' => Symbol.eq (s, s')) l
70 :     end
71 :    
72 :     fun cons (s, []) = if isSpecial s then [] else [(s, 0)]
73 :     | cons (s, l as ((s', m) :: t)) =
74 :     if isSpecial s then l
75 :     else if Symbol.eq (s, s') then (s, m+1) :: t
76 :     else (s, 0) :: l
77 :    
78 :     fun getCore s = let
79 : blume 677 fun err _ _ _ = raise NoCore
80 : blume 675 in
81 :     Lookup.lookVal (senv, SP.SPATH [CoreSym.coreSym,
82 :     Symbol.varSymbol s], err)
83 :     end
84 :    
85 :     fun getCoreVal s =
86 :     case getCore s of
87 :     VC.VAL r => r
88 :     | _ => impossible "getCoreVal"
89 :    
90 :     fun getCoreCon s =
91 :     case getCore s of
92 :     VC.CON c => c
93 :     | _ => impossible "getCoreCon"
94 :    
95 : blume 677 val bt_reserve = getCoreVal "bt_reserve"
96 : blume 675 val bt_register = getCoreVal "bt_register"
97 :     val bt_save = getCoreVal "bt_save"
98 :     val bt_push = getCoreVal "bt_push"
99 : blume 679 val bt_nopush = getCoreVal "bt_nopush"
100 : blume 675 val bt_add = getCoreVal "bt_add"
101 :     val matchcon = getCoreCon "Match"
102 :    
103 : blume 677 val bt_register_var = tmpvar ("<bt_register>", iis_u_Ty)
104 : blume 675 val bt_save_var = tmpvar ("<bt_save>", u_u_u_Ty)
105 : blume 679 val bt_push_var = tmpvar ("<bt_push>", ii_u_u_Ty)
106 :     val bt_nopush_var = tmpvar ("<bt_nopush>", ii_u_Ty)
107 : blume 677 val bt_add_var = tmpvar ("<bt_add>", ii_u_Ty)
108 :     val bt_reserve_var = tmpvar ("<bt_reserve>", i_i_Ty)
109 :     val bt_module_var = tmpvar ("<bt_module>", BT.intTy)
110 : blume 675
111 :     fun VARexp v = A.VARexp (ref v, [])
112 :     fun INTexp i = A.INTexp (IntInf.fromInt i, BT.intTy)
113 :    
114 :     val uExp = EU.unitExp
115 :     val pushexp = A.APPexp (VARexp bt_push_var, uExp)
116 :     val saveexp = A.APPexp (VARexp bt_save_var, uExp)
117 :    
118 : blume 679 fun mkmodidexp fctvar id =
119 :     A.APPexp (VARexp fctvar,
120 :     EU.TUPLEexp [VARexp bt_module_var, INTexp id])
121 :    
122 :     val mkaddexp = mkmodidexp bt_add_var
123 :     val mkpushexp = mkmodidexp bt_push_var
124 :     val mknopushexp = mkmodidexp bt_nopush_var
125 :    
126 : blume 675 fun mkregexp (id, s) =
127 :     A.APPexp (VARexp bt_register_var,
128 : blume 677 EU.TUPLEexp [VARexp bt_module_var,
129 :     INTexp id, A.STRINGexp s])
130 : blume 675
131 :     val regexps = ref []
132 : blume 677 val next = ref 0
133 : blume 675
134 : blume 679 fun newid s = let
135 :     val id = !next
136 :     in
137 :     next := id + 1;
138 :     regexps := mkregexp (id, s) :: !regexps;
139 :     id
140 :     end
141 : blume 675
142 : blume 679 val mkadd = mkaddexp o newid
143 :     val mkpush = mkpushexp o newid
144 :     val mknopush = mknopushexp o newid
145 :    
146 : blume 675 fun VALdec (v, e) =
147 :     A.VALdec [A.VB { pat = A.VARpat v, exp = e,
148 :     tyvars = ref [], boundtvs = [] }]
149 :     fun LETexp (v, e, b) = A.LETexp (VALdec (v, e), b)
150 :     fun AUexp v = A.APPexp (VARexp v, uExp) (* apply to unit *)
151 :    
152 :     fun is_prim_exp (A.VARexp (ref (VC.VALvar v), _)) =
153 :     II.isPrimInfo (#info v)
154 :     | is_prim_exp (A.CONexp _) = true
155 :     | is_prim_exp (A.CONSTRAINTexp (e, _)) = is_prim_exp e
156 :     | is_prim_exp (A.MARKexp (e, _)) = is_prim_exp e
157 :     | is_prim_exp _ = false
158 :    
159 : blume 679 fun is_raise_exp (A.RAISEexp (e, _)) =
160 :     let fun is_simple_exn (A.VARexp _) = true
161 :     | is_simple_exn (A.CONexp _) = true
162 :     | is_simple_exn (A.CONSTRAINTexp (e, _)) = is_simple_exn e
163 :     | is_simple_exn (A.MARKexp (e, _)) = is_simple_exn e
164 :     | is_simple_exn (A.RAISEexp (e, _)) =
165 :     is_simple_exn e (* !! *)
166 :     | is_simple_exn _ = false
167 :     in
168 :     is_simple_exn e
169 :     end
170 : blume 678 | is_raise_exp (A.MARKexp (e, _) |
171 :     A.CONSTRAINTexp (e, _) |
172 :     A.SEQexp [e]) = is_raise_exp e
173 :     | is_raise_exp _ = false
174 :    
175 : blume 679 fun mkDescr ((n, r), what) = let
176 :     fun name ((s, 0), a) = Symbol.name s :: a
177 :     | name ((s, m), a) = Symbol.name s :: "[" ::
178 :     Int.toString (m + 1) :: "]" :: a
179 :     fun dot ([z], a) = name (z, a)
180 :     | dot (h :: t, a) = dot (t, "." :: name (h, a))
181 :     | dot ([], a) = impossible (what ^ ": no path")
182 :     val ms = matchstring r
183 :     in
184 :     concat (ms :: ": " :: dot (n, []))
185 :     end
186 :    
187 : blume 675 fun i_exp _ loc (A.RECORDexp l) =
188 :     A.RECORDexp (map (fn (l, e) => (l, i_exp false loc e)) l)
189 :     | i_exp _ loc (A.SELECTexp (l, e)) =
190 :     A.SELECTexp (l, i_exp false loc e)
191 :     | i_exp _ loc (A.VECTORexp (l, t)) =
192 :     A.VECTORexp (map (i_exp false loc) l, t)
193 :     | i_exp tail loc (A.PACKexp (e, t, tcl)) =
194 :     A.PACKexp (i_exp tail loc e, t, tcl)
195 : blume 679 | i_exp tail loc (e as A.APPexp (f, a)) = let
196 :     val mainexp = A.APPexp (i_exp false loc f, i_exp false loc a)
197 :     in
198 :     if is_prim_exp f then mainexp
199 :     else if tail then A.SEQexp [mknopush (mkDescr (loc, "GOTO")),
200 :     mainexp]
201 :     else let
202 :     val ty = Reconstruct.expType e
203 :     val result = tmpvar ("tmpresult", ty)
204 :     val restore = tmpvar ("tmprestore", u_u_Ty)
205 :     val pushexp = mkpush (mkDescr (loc, "CALL"))
206 :     in
207 :     LETexp (restore, pushexp,
208 :     LETexp (result, mainexp,
209 :     A.SEQexp [AUexp restore,
210 :     VARexp result]))
211 :     end
212 :     end
213 : blume 675 | i_exp tail loc (A.HANDLEexp (e, A.HANDLER (A.FNexp (rl, t)))) = let
214 :     val restore = tmpvar ("tmprestore", u_u_Ty)
215 : blume 678 fun rule (r as A.RULE (p, e)) =
216 :     if is_raise_exp e then r
217 :     else A.RULE (p, A.SEQexp [AUexp restore, i_exp tail loc e])
218 : blume 675 in
219 :     LETexp (restore, saveexp,
220 :     A.HANDLEexp (i_exp false loc e,
221 :     A.HANDLER (A.FNexp (map rule rl, t))))
222 :     end
223 :     | i_exp _ _ (A.HANDLEexp _) = impossible "bad HANDLEexp"
224 :     | i_exp _ loc (A.RAISEexp (e, t)) =
225 :     A.RAISEexp (i_exp false loc e, t)
226 :     | i_exp tail loc (A.CASEexp (e, rl, b)) =
227 :     A.CASEexp (i_exp false loc e, map (i_rule tail loc) rl, b)
228 :     | i_exp tail loc (A.FNexp (rl, t)) = let
229 : blume 679 val addexp = mkadd (mkDescr (loc, "FN"))
230 : blume 675 val arg = tmpvar ("fnvar", t)
231 :     val rl' = map (i_rule true loc) rl
232 :     val re = let
233 :     val A.RULE (_, lst) = List.last rl
234 :     val t = Reconstruct.expType lst
235 :     in
236 :     A.RAISEexp (A.CONexp (matchcon, []), t)
237 :     end
238 :     in
239 :     A.FNexp ([A.RULE (A.VARpat arg,
240 :     A.SEQexp [addexp,
241 :     A.CASEexp (A.VARexp (ref arg, []),
242 :     rl', true)]),
243 :     A.RULE (A.WILDpat, re)],
244 :     t)
245 :     end
246 :     | i_exp tail loc (A.LETexp (d, e)) =
247 :     A.LETexp (i_dec loc d, i_exp tail loc e)
248 :     | i_exp tail loc (A.SEQexp l) =
249 :     A.SEQexp (#1 (foldr (fn (e, (l, t)) => (i_exp t loc e :: l, false))
250 :     ([], tail) l))
251 :     | i_exp tail loc (A.CONSTRAINTexp (e, t)) =
252 :     A.CONSTRAINTexp (i_exp tail loc e, t)
253 :     | i_exp tail (n, _) (A.MARKexp (e, r)) =
254 :     A.MARKexp (i_exp tail (n, r) e, r)
255 :     | i_exp _ _ e = e
256 :    
257 :     and i_dec loc (A.VALdec l) = A.VALdec (map (i_vb loc) l)
258 :     | i_dec loc (A.VALRECdec l) = A.VALRECdec (map (i_rvb loc) l)
259 :     | i_dec loc (A.ABSTYPEdec { abstycs, withtycs, body }) =
260 :     A.ABSTYPEdec { abstycs = abstycs, withtycs = withtycs,
261 :     body = i_dec loc body }
262 :     | i_dec loc (A.EXCEPTIONdec l) = A.EXCEPTIONdec (map (i_eb loc) l)
263 :     | i_dec loc (A.STRdec l) = A.STRdec (map (i_strb loc) l)
264 :     | i_dec loc (A.ABSdec l) = A.ABSdec (map (i_strb loc) l)
265 :     | i_dec loc (A.FCTdec l) = A.FCTdec (map (i_fctb loc) l)
266 :     | i_dec loc (A.LOCALdec (d, d')) =
267 :     A.LOCALdec (i_dec loc d, i_dec loc d')
268 :     | i_dec loc (A.SEQdec l) = A.SEQdec (map (i_dec loc) l)
269 :     | i_dec (n, _) (A.MARKdec (d, r)) = A.MARKdec (i_dec (n, r) d, r)
270 :     | i_dec _ d = d
271 :    
272 :     and i_rule tail loc (A.RULE (p, e)) = A.RULE (p, i_exp tail loc e)
273 :    
274 :     and i_vb (n, r) (vb as A.VB { pat, exp, boundtvs, tyvars }) = let
275 :     fun gv (A.VARpat v) = SOME v
276 :     | gv (A.CONSTRAINTpat (p, _)) = gv p
277 :     | gv (A.LAYEREDpat (p, p')) =
278 :     (case gv p of
279 :     SOME v => SOME v
280 :     | NONE => gv p')
281 :     | gv _ = NONE
282 :     fun recur n = A.VB { pat = pat, exp = i_exp false (n, r) exp,
283 :     boundtvs = boundtvs, tyvars = tyvars }
284 :     in
285 :     case gv pat of
286 :     SOME (VC.VALvar { path = SP.SPATH [x], info, ... }) =>
287 :     if II.isPrimInfo info then vb else recur (cons (x, n))
288 :     | SOME (VC.VALvar { info, ... }) =>
289 :     if II.isPrimInfo info then vb else recur n
290 :     | _ => recur n
291 :     end
292 :    
293 :     and i_rvb (n, r) (A.RVB { var, exp, boundtvs, resultty, tyvars }) = let
294 :     val x =
295 :     case var of
296 :     VC.VALvar { path = SymPath.SPATH [x], ... } => x
297 :     | _ => impossible "VALRECdec"
298 :     in
299 :     A.RVB { var = var, exp = i_exp false (cons (x, n), r) exp,
300 :     boundtvs = boundtvs, resultty = resultty, tyvars = tyvars }
301 :     end
302 :    
303 :     and i_eb loc (A.EBgen { exn, etype, ident }) =
304 :     A.EBgen { exn = exn, etype = etype, ident = i_exp false loc ident }
305 :     | i_eb _ eb = eb
306 :    
307 :     and i_strb (n, r) (A.STRB { name, str, def }) =
308 :     A.STRB { name = name, str = str,
309 :     def = i_strexp (cons (name, n), r) def }
310 :    
311 :     and i_fctb (n, r) (A.FCTB { name, fct, def }) =
312 :     A.FCTB { name = name, fct = fct,
313 :     def = i_fctexp (cons (name, n), r) def }
314 :    
315 :     and i_strexp loc (A.LETstr (d, s)) =
316 :     A.LETstr (i_dec loc d, i_strexp loc s)
317 :     | i_strexp (n, _) (A.MARKstr (s, r)) =
318 :     A.MARKstr (i_strexp (n, r) s, r)
319 :     | i_strexp _ s = s
320 :    
321 :     and i_fctexp loc (A.FCTfct { param, argtycs, def }) =
322 :     A.FCTfct { param = param, argtycs = argtycs,
323 :     def = i_strexp loc def }
324 :     | i_fctexp loc (A.LETfct (d, f)) =
325 :     A.LETfct (i_dec loc d, i_fctexp loc f)
326 :     | i_fctexp (n, _) (A.MARKfct (f, r)) =
327 :     A.MARKfct (i_fctexp (n, r) f, r)
328 :     | i_fctexp _ f = f
329 :    
330 :     val d' = i_dec ([], (0, 0)) d
331 :     in
332 : blume 677 A.LOCALdec (A.SEQdec [VALdec (bt_reserve_var, AUexp bt_reserve),
333 :     VALdec (bt_module_var,
334 :     A.APPexp (VARexp bt_reserve_var,
335 :     INTexp (!next))),
336 :     VALdec (bt_save_var, AUexp bt_save),
337 : blume 675 VALdec (bt_push_var, AUexp bt_push),
338 : blume 679 VALdec (bt_nopush_var, AUexp bt_nopush),
339 : blume 675 VALdec (bt_register_var, AUexp bt_register),
340 :     VALdec (bt_add_var,
341 :     A.SEQexp (!regexps @ [AUexp bt_add]))],
342 :     d')
343 :     end
344 :    
345 :     fun instrument params d =
346 : blume 677 if SMLofNJ.Internals.BTrace.mode NONE then
347 :     instrument0 params d
348 :     handle NoCore => d (* this takes care of core.sml *)
349 : blume 675 else d
350 :     end
351 :    
352 :     end (* local *)

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