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

Parent Directory | Revision Log

---

Revision 1332 - (view) (download)

1 :	blume	903	(* Copyright 1996 by Bell Laboratories *)
2 :			(* tprof.sml *)
3 :
4 :			signature TPROF =
5 :			sig
6 :			(* The first (curried) argument is a function that should return true
7 :			* if the operator (specified via inlining info) can return multiple
8 :			* times. In practical terms, this means call/cc. *)
9 :			val instrumDec :
10 :			(II.ii -> bool) ->
11 :			(StaticEnv.staticEnv * Absyn.dec CompInfo.compInfo)
12 :			-> Absyn.dec -> Absyn.dec
13 :
14 :			end (* signature TPROF *)
15 :
16 :			structure TProf : TPROF =
17 :			struct
18 :
19 :			local structure SP = SymPath
20 :			structure V = VarCon
21 :			structure M = Modules
22 :			structure B = Bindings
23 :			structure A = Access
24 :			(* structure II' = InlInfo *)
25 :			(* structure P = PrimOp *)
26 :			structure S = Symbol
27 :			open Absyn VarCon Types
28 :
29 :			val TUPLEexp = AbsynUtil.TUPLEexp
30 :			val TUPLEpat = AbsynUtil.TUPLEpat
31 :
32 :			structure BT = CoreBasicTypes
33 :			val intTy = BT.intTy
34 :			val unitTy = BT.unitTy
35 :			val tupleTy = BT.tupleTy
36 :			val refTycon = BT.refTycon
37 :			val arrayTycon = BT.arrayTycon
38 :			val --> = BT.-->
39 :			infix -->
40 :			in
41 :
42 :
43 :			fun bug s = ErrorMsg.impossible ("Prof: "^s)
44 :
45 :			val anonSym = S.varSymbol "anon"
46 :			val intreftype = CONty(refTycon, [intTy])
47 :
48 :			fun poly1 ty =
49 :			POLYty{sign=[false], tyfun=TYFUN{arity=1, body=ty}}
50 :
51 :			(* We get this stuff via CoreAccess now. This way we don't need
52 :			* to know the actual primops.... *)
53 :			(*
54 :			val updateop =
55 :			let val t = poly1(tupleTy[CONty(arrayTycon,[IBOUND 0]),
56 :			intTy, IBOUND 0] --> unitTy)
57 :			in VALvar{path=SP.SPATH[S.varSymbol "unboxedupdate"], typ=ref t,
58 :			access=A.nullAcc,
59 :			info=II'.mkPrimInfo(P.UNBOXEDUPDATE, t)}
60 :			end
61 :
62 :			val assignop =
63 :			let val t = poly1(tupleTy[CONty(refTycon,[IBOUND 0]), intTy, IBOUND 0]
64 :			--> unitTy)
65 :
66 :			in VALvar{path=SP.SPATH[S.varSymbol ":="], typ=ref t,
67 :			access=A.nullAcc,
68 :			info=II'.mkPrimInfo(P.ASSIGN, t)}
69 :			end
70 :
71 :			val subop =
72 :			let val t = poly1(tupleTy[CONty(arrayTycon,[IBOUND 0]), intTy] --> IBOUND 0)
73 :			in VALvar{path=SP.SPATH[S.varSymbol "subscript"], typ=ref t,
74 :			access=A.nullAcc,
75 :			info=II'.mkPrimInfo(P.SUBSCRIPT, t)}
76 :			end
77 :
78 :			val derefop =
79 :			let val t = poly1(CONty(refTycon,[IBOUND 0]) --> IBOUND 0)
80 :			in VALvar{path=SP.SPATH [S.varSymbol "!"], typ=ref t,
81 :			access=A.nullAcc, info=II'.mkPrimInfo(P.DEREF, t)}
82 :			end
83 :
84 :			val addop =
85 :			let val t = (tupleTy[intTy,intTy] --> intTy)
86 :			in VALvar{path=SP.SPATH[S.varSymbol "iadd"], typ=ref t,
87 :			access=A.nullAcc, info=II'.mkPrimInfo(P.IADD, t)}
88 :			end
89 :			*)
90 :
91 :			fun tmpvar(str,ty,mkv) =
92 :			let val sym = S.varSymbol str
93 :			in VALvar{access=A.namedAcc(sym, mkv), info=II.Null,
94 :			path=SP.SPATH[sym], typ=ref ty}
95 :			end
96 :
97 :			fun varexp(v as VALvar{typ=ref ty,path,...}) =
98 :			(case TypesUtil.headReduceType ty
99 :			of POLYty _ =>
100 :			bug ("poly["^SP.toString path^"] in Prof")
101 :			| ty' => VARexp(ref v, [])) (* VARexp(ref v, SOME ty') *)
102 :			| varexp _ = bug "090924 in prof"
103 :
104 :			fun clean (path as name::names) = if S.eq(name,anonSym) then names else path
105 :			| clean x = x
106 :
107 :			fun instrumDec' mayReturnMoreThanOnce (env, compInfo) absyn =
108 :			let fun getVar name = CoreAccess.getVar (env, name)
109 :			val updateop = getVar "unboxedupdate"
110 :			val assignop = getVar "assign"
111 :			val subop = getVar "subscript"
112 :			val derefop = getVar "deref"
113 :			val addop = getVar "iadd"
114 :
115 :			val mkv = #mkLvar (compInfo: Absyn.dec CompInfo.compInfo)
116 :			val countarrayvar = tmpvar("countarray", CONty(arrayTycon,[intTy]),mkv)
117 :			val countarray = varexp countarrayvar
118 :
119 :			val basevar = tmpvar("base", intTy, mkv)
120 :			val baseexp = varexp basevar
121 :
122 :			val currentvar = tmpvar("profCurrent",CONty(refTycon,[intTy]), mkv)
123 :			val currentexp = varexp currentvar
124 :
125 :	blume	904	val register = CoreAccess.getVar (env, "profile_register")
126 :	blume	903
127 :			local
128 :			val ty = case register of
129 :			VALvar { typ = ref ty, ... } => ty
130 :			| _ => bug "298374 in prof"
131 :			in
132 :			val profDerefTy =
133 :			case TypesUtil.headReduceType ty of
134 :			CONty (_, [ty']) => ty'
135 :			| _ => bug "298342 in prof"
136 :			end
137 :
138 :			val entries = ref (nil: string list)
139 :			val entrycount = ref 0
140 :			fun makeEntry(name) = let val i = !entrycount
141 :			in entries := "\n" :: name :: !entries;
142 :			entrycount := i+1;
143 :			i
144 :			end
145 :
146 :			val intUpdTy = tupleTy[CONty(arrayTycon,[intTy]),intTy,intTy] --> unitTy
147 :			val intSubTy = tupleTy[CONty(arrayTycon,[intTy]),intTy] --> intTy
148 :
149 :			fun BUMPCCexp (ccvara : int) =
150 :			let val lvar = tmpvar("indexvar",intTy,mkv)
151 :			in APPexp(VARexp(ref updateop,[intTy]),
152 :			TUPLEexp[countarray,
153 :			INTexp (IntInf.fromInt ccvara, intTy),
154 :			APPexp(varexp addop,
155 :			TUPLEexp[APPexp(VARexp(ref subop,[intTy]),
156 :			TUPLEexp[countarray,
157 :			INTexp(IntInf.fromInt ccvara,intTy)]),
158 :			INTexp (IntInf.fromInt 1,intTy)])])
159 :			end
160 :
161 :			val intAssTy = tupleTy[CONty(refTycon,[intTy]),intTy] --> unitTy
162 :
163 :			fun SETCURRENTexp (ccvara : int) =
164 :			let val lvar = tmpvar("indexvar",intTy, mkv)
165 :			in LETexp(VALdec[VB{pat=VARpat(lvar),
166 :			exp=APPexp(varexp addop,
167 :			TUPLEexp[INTexp (IntInf.fromInt ccvara,
168 :			intTy),
169 :			baseexp]),
170 :			tyvars=ref nil,
171 :			boundtvs=[]}],
172 :			APPexp(VARexp(ref assignop,[intTy]),
173 :			TUPLEexp[currentexp, varexp lvar]))
174 :			end
175 :
176 :			fun instrdec(sp as (names,ccvara), VALdec vbl) =
177 :			let fun getvar(VARpat v) = SOME v
178 :			| getvar(CONSTRAINTpat(p,_)) = getvar p
179 :			| getvar _ = NONE
180 :
181 :			fun instrvb(vb as VB{pat,exp,tyvars,boundtvs}) =
182 :			(case getvar pat
183 :			of SOME(VALvar{info, path=SP.SPATH[n],...}) =>
184 :			if II.isSimple info then vb
185 :			else VB{pat=pat, tyvars=tyvars,
186 :			exp=instrexp (n::clean names,
187 :			ccvara) false exp,
188 :			boundtvs=boundtvs}
189 :			| SOME(VALvar{info, ...}) =>
190 :			if II.isSimple info then vb
191 :			else VB{pat=pat, exp=instrexp sp false exp,
192 :			tyvars=tyvars, boundtvs=boundtvs}
193 :			| _ => VB{pat=pat, exp=instrexp sp false exp,
194 :			tyvars=tyvars, boundtvs=boundtvs})
195 :
196 :			in VALdec (map instrvb vbl)
197 :			end
198 :
199 :			| instrdec(sp as (names,ccvara), VALRECdec rvbl) =
200 :			let fun instrrvb (RVB{var as VALvar{path=SP.SPATH[n],...},
201 :			exp,resultty,tyvars,boundtvs}) =
202 :			RVB{exp=instrexp(n::clean names, ccvara) false exp,
203 :			var=var, resultty=resultty, tyvars=tyvars,
204 :			boundtvs=boundtvs}
205 :
206 :			| instrrvb _ = bug "VALRECdec in instrdec"
207 :			in VALRECdec(map instrrvb rvbl)
208 :			end
209 :
210 :			| instrdec(sp, ABSTYPEdec {abstycs,withtycs,body}) =
211 :			ABSTYPEdec {abstycs=abstycs,withtycs=withtycs,
212 :			body=instrdec(sp,body)}
213 :
214 :			| instrdec(sp, STRdec strbl) =
215 :			STRdec (map (fn strb => instrstrb(sp,strb)) strbl)
216 :
217 :			| instrdec(sp, ABSdec strbl) =
218 :			ABSdec (map (fn strb => instrstrb(sp,strb)) strbl)
219 :
220 :			| instrdec(sp, FCTdec fctbl) =
221 :			FCTdec (map (fn fctb => instrfctb(sp,fctb)) fctbl)
222 :
223 :			| instrdec(sp, LOCALdec(localdec,visibledec)) =
224 :			LOCALdec(instrdec (sp,localdec), instrdec (sp,visibledec))
225 :
226 :			| instrdec(sp, SEQdec decl) =
227 :			SEQdec (map (fn dec => instrdec(sp,dec)) decl)
228 :
229 :			| instrdec(sp, MARKdec(dec,region)) =
230 :			MARKdec(instrdec (sp,dec), region)
231 :
232 :			| instrdec(sp, other) = other
233 :
234 :			and instrstrexp(names, LETstr(d,body)) =
235 :			LETstr(instrdec((names,0),d), instrstrexp(names,body))
236 :
237 :			| instrstrexp(names,MARKstr(body,region)) =
238 :			MARKstr(instrstrexp(names,body),region)
239 :
240 :			| instrstrexp(names, x) = x
241 :
242 :			and instrstrb ((names,ccvara), STRB{name, str, def}) =
243 :			STRB{str=str, def=instrstrexp(name::names,def), name=name}
244 :
245 :			and instrfctexp(names, FCTfct {param, def, argtycs}) =
246 :			FCTfct{param=param, def=instrstrexp(names,def), argtycs=argtycs}
247 :
248 :			| instrfctexp(names, LETfct(d,body)) =
249 :			LETfct(instrdec((names,0),d), instrfctexp(names,body))
250 :
251 :			| instrfctexp(names,MARKfct(body,region)) =
252 :			MARKfct(instrfctexp(names,body),region)
253 :
254 :			| instrfctexp(names, x) = x
255 :
256 :			and instrfctb ((names,ccvara), FCTB{name, fct, def}) =
257 :			FCTB{name=name, fct=fct, def=instrfctexp(name::names,def)}
258 :
259 :			and instrexp(sp as (names,ccvara)) =
260 :			let fun istail tail =
261 :			let fun iinstr exp = istail false exp
262 :			fun oinstr exp = istail true exp
263 :			fun instrrules tr = map (fn (RULE(p,e)) => RULE(p, tr e))
264 :
265 :			val rec instr:(exp->exp) =
266 :			fn RECORDexp l =>
267 :			RECORDexp(map (fn (lab,exp) => (lab,iinstr exp)) l)
268 :
269 :			| VECTORexp(l,t) => VECTORexp((map iinstr l),t)
270 :
271 :			| SEQexp l =>
272 :			let fun seq [e] = [instr e]
273 :			| seq (e::r) = (iinstr e)::(seq r)
274 :			| seq nil = nil
275 :			in SEQexp (seq l)
276 :			end
277 :
278 :	mblume	1332	| IFexp { test, thenCase, elseCase } =>
279 :			IFexp { test = iinstr test,
280 :			thenCase = instr thenCase,
281 :			elseCase = instr elseCase }
282 :
283 :			| ANDALSOexp (e1, e2) =>
284 :			ANDALSOexp (iinstr e1, instr e2)
285 :			| ORELSEexp (e1, e2) =>
286 :			ORELSEexp (iinstr e1, instr e2)
287 :			| WHILEexp { test, expr } =>
288 :			WHILEexp { test = iinstr test, expr = iinstr expr }
289 :
290 :	blume	903	| exp as APPexp (f,a) =>
291 :			let fun safe(VARexp(ref(VALvar{info, ...}), _)) =
292 :			if II.isSimple info then
293 :			(if mayReturnMoreThanOnce info then false
294 :			else true)
295 :			else false
296 :			| safe(MARKexp(e,_)) = safe e
297 :			| safe(CONSTRAINTexp(e,_)) = safe e
298 :			| safe(SEQexp[e]) = safe e
299 :			| safe _ = false
300 :
301 :			fun rator_instr a =
302 :			case a
303 :			of APPexp(randf,_) =>
304 :			if safe randf then iinstr else oinstr
305 :			| VARexp _ => oinstr
306 :			| MARKexp(e,_) => rator_instr e
307 :			| CONSTRAINTexp(e,_) => rator_instr e
308 :			| SEQexp[e] => rator_instr e
309 :			| _ => iinstr
310 :
311 :			val f' = rator_instr a f
312 :
313 :			in if tail orelse (safe f)
314 :			then APPexp (f', oinstr a)
315 :			else let val ty = Reconstruct.expType exp
316 :			val lvar = tmpvar("appvar",ty,mkv)
317 :			in LETexp (VALdec[VB{pat=VARpat(lvar),
318 :			exp=APPexp(f', oinstr a),
319 :			tyvars=ref nil,
320 :			boundtvs=[]}],
321 :			SEQexp([SETCURRENTexp(ccvara),
322 :			varexp lvar]))
323 :			end
324 :			end
325 :
326 :			| CONSTRAINTexp(e,t) => CONSTRAINTexp(instr e, t)
327 :
328 :			| HANDLEexp (e, HANDLER(FNexp(l,t)))=>
329 :			let fun rule(RULE(p,e)) =
330 :			RULE(p,SEQexp[SETCURRENTexp ccvara, instr e])
331 :			in HANDLEexp (instr e, HANDLER(FNexp(map rule l,t)))
332 :			end
333 :
334 :			| RAISEexp(e, t) => RAISEexp(oinstr e, t)
335 :
336 :			| LETexp (d, e) => LETexp (instrdec(sp,d), instr e)
337 :
338 :			| PACKexp(e, t, tycs) => PACKexp(oinstr e, t, tycs)
339 :
340 :			| CASEexp (e, l, b) =>
341 :			CASEexp(iinstr e, instrrules instr l, b)
342 :
343 :			| FNexp(l,t) =>
344 :			let fun dot (a,[z]) = S.name z :: a
345 :			| dot (a,x::rest) =
346 :			dot("." :: S.name x :: a, rest)
347 :			| dot _ = bug "no path in instrexp"
348 :
349 :			val name = concat (dot ([], names))
350 :			val ccvara' = makeEntry(name)
351 :			val lvar = tmpvar("fnvar",t,mkv);
352 :
353 :	blume	904	val exnMatch = CoreAccess.getCon (env, "Match")
354 :	blume	903
355 :			val RULE(_,special) = List.last l
356 :			in FNexp ([RULE(VARpat(lvar),
357 :			SEQexp ([BUMPCCexp(ccvara'),
358 :			SETCURRENTexp(ccvara'),
359 :			CASEexp(varexp lvar,
360 :			instrrules (instrexp (anonSym::names,
361 :			ccvara') true) l,
362 :			true)])),
363 :			RULE(WILDpat,RAISEexp(CONexp(exnMatch,[]),
364 :			Reconstruct.expType special))
365 :			], t)
366 :			end
367 :			| MARKexp(e,region) => MARKexp(instr e, region)
368 :			| e => e
369 :
370 :			in instr
371 :			end
372 :			in istail
373 :			end (* function instrexp *)
374 :
375 :			val absyn1 = instrdec(([],0),absyn)
376 :
377 :			(*
378 :			* The following break the invariant set in the absyn.sml where
379 :			* the pat in each VB binding should bind single variables !;
380 :			* The following VB only binds monomorphic variables, so it is
381 :			* probably ok for the time being. We definitely should clean it
382 :			* up some time in the future. (ZHONG)
383 :			*)
384 :
385 :			val absyn2 =
386 :			LOCALdec(VALdec[VB{pat=TUPLEpat[VARpat basevar,
387 :			VARpat countarrayvar,
388 :			VARpat currentvar],
389 :			exp=APPexp(APPexp(VARexp(ref derefop,
390 :			[profDerefTy]),
391 :			varexp register),
392 :			STRINGexp(concat(rev(!entries)))),
393 :			tyvars=ref nil,
394 :			boundtvs=[]}],
395 :			absyn1)
396 :
397 :			in absyn2
398 :			end
399 :
400 :			fun instrumDec mrmto (env, compInfo) absyn =
401 :			if !SMLofNJ.Internals.ProfControl.profMode
402 :			then instrumDec' mrmto (env, compInfo) absyn
403 :			else absyn
404 :
405 :			end (* local *)
406 :			end (* structure TProf *)
407 :
408 :

---

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