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

Parent Directory | Revision Log

---

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

---

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