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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 903 - (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 :     val register =
126 :     case Lookup.lookVal
127 :     (env,
128 :     SP.SPATH [CoreSym.coreSym,
129 :     S.varSymbol "profile_register"],
130 :     fn _ => fn s => fn _ => bug "222 in prof") of
131 :     V.VAL r => r
132 :     | _ => bug "09824 in prof"
133 :    
134 :     local
135 :     val ty = case register of
136 :     VALvar { typ = ref ty, ... } => ty
137 :     | _ => bug "298374 in prof"
138 :     in
139 :     val profDerefTy =
140 :     case TypesUtil.headReduceType ty of
141 :     CONty (_, [ty']) => ty'
142 :     | _ => bug "298342 in prof"
143 :     end
144 :    
145 :     val entries = ref (nil: string list)
146 :     val entrycount = ref 0
147 :     fun makeEntry(name) = let val i = !entrycount
148 :     in entries := "\n" :: name :: !entries;
149 :     entrycount := i+1;
150 :     i
151 :     end
152 :    
153 :     val intUpdTy = tupleTy[CONty(arrayTycon,[intTy]),intTy,intTy] --> unitTy
154 :     val intSubTy = tupleTy[CONty(arrayTycon,[intTy]),intTy] --> intTy
155 :    
156 :     fun BUMPCCexp (ccvara : int) =
157 :     let val lvar = tmpvar("indexvar",intTy,mkv)
158 :     in APPexp(VARexp(ref updateop,[intTy]),
159 :     TUPLEexp[countarray,
160 :     INTexp (IntInf.fromInt ccvara, intTy),
161 :     APPexp(varexp addop,
162 :     TUPLEexp[APPexp(VARexp(ref subop,[intTy]),
163 :     TUPLEexp[countarray,
164 :     INTexp(IntInf.fromInt ccvara,intTy)]),
165 :     INTexp (IntInf.fromInt 1,intTy)])])
166 :     end
167 :    
168 :     val intAssTy = tupleTy[CONty(refTycon,[intTy]),intTy] --> unitTy
169 :    
170 :     fun SETCURRENTexp (ccvara : int) =
171 :     let val lvar = tmpvar("indexvar",intTy, mkv)
172 :     in LETexp(VALdec[VB{pat=VARpat(lvar),
173 :     exp=APPexp(varexp addop,
174 :     TUPLEexp[INTexp (IntInf.fromInt ccvara,
175 :     intTy),
176 :     baseexp]),
177 :     tyvars=ref nil,
178 :     boundtvs=[]}],
179 :     APPexp(VARexp(ref assignop,[intTy]),
180 :     TUPLEexp[currentexp, varexp lvar]))
181 :     end
182 :    
183 :     fun instrdec(sp as (names,ccvara), VALdec vbl) =
184 :     let fun getvar(VARpat v) = SOME v
185 :     | getvar(CONSTRAINTpat(p,_)) = getvar p
186 :     | getvar _ = NONE
187 :    
188 :     fun instrvb(vb as VB{pat,exp,tyvars,boundtvs}) =
189 :     (case getvar pat
190 :     of SOME(VALvar{info, path=SP.SPATH[n],...}) =>
191 :     if II.isSimple info then vb
192 :     else VB{pat=pat, tyvars=tyvars,
193 :     exp=instrexp (n::clean names,
194 :     ccvara) false exp,
195 :     boundtvs=boundtvs}
196 :     | SOME(VALvar{info, ...}) =>
197 :     if II.isSimple info then vb
198 :     else VB{pat=pat, exp=instrexp sp false exp,
199 :     tyvars=tyvars, boundtvs=boundtvs}
200 :     | _ => VB{pat=pat, exp=instrexp sp false exp,
201 :     tyvars=tyvars, boundtvs=boundtvs})
202 :    
203 :     in VALdec (map instrvb vbl)
204 :     end
205 :    
206 :     | instrdec(sp as (names,ccvara), VALRECdec rvbl) =
207 :     let fun instrrvb (RVB{var as VALvar{path=SP.SPATH[n],...},
208 :     exp,resultty,tyvars,boundtvs}) =
209 :     RVB{exp=instrexp(n::clean names, ccvara) false exp,
210 :     var=var, resultty=resultty, tyvars=tyvars,
211 :     boundtvs=boundtvs}
212 :    
213 :     | instrrvb _ = bug "VALRECdec in instrdec"
214 :     in VALRECdec(map instrrvb rvbl)
215 :     end
216 :    
217 :     | instrdec(sp, ABSTYPEdec {abstycs,withtycs,body}) =
218 :     ABSTYPEdec {abstycs=abstycs,withtycs=withtycs,
219 :     body=instrdec(sp,body)}
220 :    
221 :     | instrdec(sp, STRdec strbl) =
222 :     STRdec (map (fn strb => instrstrb(sp,strb)) strbl)
223 :    
224 :     | instrdec(sp, ABSdec strbl) =
225 :     ABSdec (map (fn strb => instrstrb(sp,strb)) strbl)
226 :    
227 :     | instrdec(sp, FCTdec fctbl) =
228 :     FCTdec (map (fn fctb => instrfctb(sp,fctb)) fctbl)
229 :    
230 :     | instrdec(sp, LOCALdec(localdec,visibledec)) =
231 :     LOCALdec(instrdec (sp,localdec), instrdec (sp,visibledec))
232 :    
233 :     | instrdec(sp, SEQdec decl) =
234 :     SEQdec (map (fn dec => instrdec(sp,dec)) decl)
235 :    
236 :     | instrdec(sp, MARKdec(dec,region)) =
237 :     MARKdec(instrdec (sp,dec), region)
238 :    
239 :     | instrdec(sp, other) = other
240 :    
241 :     and instrstrexp(names, LETstr(d,body)) =
242 :     LETstr(instrdec((names,0),d), instrstrexp(names,body))
243 :    
244 :     | instrstrexp(names,MARKstr(body,region)) =
245 :     MARKstr(instrstrexp(names,body),region)
246 :    
247 :     | instrstrexp(names, x) = x
248 :    
249 :     and instrstrb ((names,ccvara), STRB{name, str, def}) =
250 :     STRB{str=str, def=instrstrexp(name::names,def), name=name}
251 :    
252 :     and instrfctexp(names, FCTfct {param, def, argtycs}) =
253 :     FCTfct{param=param, def=instrstrexp(names,def), argtycs=argtycs}
254 :    
255 :     | instrfctexp(names, LETfct(d,body)) =
256 :     LETfct(instrdec((names,0),d), instrfctexp(names,body))
257 :    
258 :     | instrfctexp(names,MARKfct(body,region)) =
259 :     MARKfct(instrfctexp(names,body),region)
260 :    
261 :     | instrfctexp(names, x) = x
262 :    
263 :     and instrfctb ((names,ccvara), FCTB{name, fct, def}) =
264 :     FCTB{name=name, fct=fct, def=instrfctexp(name::names,def)}
265 :    
266 :     and instrexp(sp as (names,ccvara)) =
267 :     let fun istail tail =
268 :     let fun iinstr exp = istail false exp
269 :     fun oinstr exp = istail true exp
270 :     fun instrrules tr = map (fn (RULE(p,e)) => RULE(p, tr e))
271 :    
272 :     val rec instr:(exp->exp) =
273 :     fn RECORDexp l =>
274 :     RECORDexp(map (fn (lab,exp) => (lab,iinstr exp)) l)
275 :    
276 :     | VECTORexp(l,t) => VECTORexp((map iinstr l),t)
277 :    
278 :     | SEQexp l =>
279 :     let fun seq [e] = [instr e]
280 :     | seq (e::r) = (iinstr e)::(seq r)
281 :     | seq nil = nil
282 :     in SEQexp (seq l)
283 :     end
284 :    
285 :     | exp as APPexp (f,a) =>
286 :     let fun safe(VARexp(ref(VALvar{info, ...}), _)) =
287 :     if II.isSimple info then
288 :     (if mayReturnMoreThanOnce info then false
289 :     else true)
290 :     else false
291 :     | safe(MARKexp(e,_)) = safe e
292 :     | safe(CONSTRAINTexp(e,_)) = safe e
293 :     | safe(SEQexp[e]) = safe e
294 :     | safe _ = false
295 :    
296 :     fun rator_instr a =
297 :     case a
298 :     of APPexp(randf,_) =>
299 :     if safe randf then iinstr else oinstr
300 :     | VARexp _ => oinstr
301 :     | MARKexp(e,_) => rator_instr e
302 :     | CONSTRAINTexp(e,_) => rator_instr e
303 :     | SEQexp[e] => rator_instr e
304 :     | _ => iinstr
305 :    
306 :     val f' = rator_instr a f
307 :    
308 :     in if tail orelse (safe f)
309 :     then APPexp (f', oinstr a)
310 :     else let val ty = Reconstruct.expType exp
311 :     val lvar = tmpvar("appvar",ty,mkv)
312 :     in LETexp (VALdec[VB{pat=VARpat(lvar),
313 :     exp=APPexp(f', oinstr a),
314 :     tyvars=ref nil,
315 :     boundtvs=[]}],
316 :     SEQexp([SETCURRENTexp(ccvara),
317 :     varexp lvar]))
318 :     end
319 :     end
320 :    
321 :     | CONSTRAINTexp(e,t) => CONSTRAINTexp(instr e, t)
322 :    
323 :     | HANDLEexp (e, HANDLER(FNexp(l,t)))=>
324 :     let fun rule(RULE(p,e)) =
325 :     RULE(p,SEQexp[SETCURRENTexp ccvara, instr e])
326 :     in HANDLEexp (instr e, HANDLER(FNexp(map rule l,t)))
327 :     end
328 :    
329 :     | RAISEexp(e, t) => RAISEexp(oinstr e, t)
330 :    
331 :     | LETexp (d, e) => LETexp (instrdec(sp,d), instr e)
332 :    
333 :     | PACKexp(e, t, tycs) => PACKexp(oinstr e, t, tycs)
334 :    
335 :     | CASEexp (e, l, b) =>
336 :     CASEexp(iinstr e, instrrules instr l, b)
337 :    
338 :     | FNexp(l,t) =>
339 :     let fun dot (a,[z]) = S.name z :: a
340 :     | dot (a,x::rest) =
341 :     dot("." :: S.name x :: a, rest)
342 :     | dot _ = bug "no path in instrexp"
343 :    
344 :     val name = concat (dot ([], names))
345 :     val ccvara' = makeEntry(name)
346 :     val lvar = tmpvar("fnvar",t,mkv);
347 :    
348 :     val exnMatch =
349 :     case Lookup.lookVal
350 :     (env,
351 :     SP.SPATH [CoreSym.coreSym,
352 :     S.varSymbol "Match"],
353 :     fn _ => fn s => fn _ =>
354 :     bug "250 in prof")
355 :     of V.CON e => e
356 :     | _ => bug "no CON for exnMatch"
357 :    
358 :     val RULE(_,special) = List.last l
359 :     in FNexp ([RULE(VARpat(lvar),
360 :     SEQexp ([BUMPCCexp(ccvara'),
361 :     SETCURRENTexp(ccvara'),
362 :     CASEexp(varexp lvar,
363 :     instrrules (instrexp (anonSym::names,
364 :     ccvara') true) l,
365 :     true)])),
366 :     RULE(WILDpat,RAISEexp(CONexp(exnMatch,[]),
367 :     Reconstruct.expType special))
368 :     ], t)
369 :     end
370 :     | MARKexp(e,region) => MARKexp(instr e, region)
371 :     | e => e
372 :    
373 :     in instr
374 :     end
375 :     in istail
376 :     end (* function instrexp *)
377 :    
378 :     val absyn1 = instrdec(([],0),absyn)
379 :    
380 :     (*
381 :     * The following break the invariant set in the absyn.sml where
382 :     * the pat in each VB binding should bind single variables !;
383 :     * The following VB only binds monomorphic variables, so it is
384 :     * probably ok for the time being. We definitely should clean it
385 :     * up some time in the future. (ZHONG)
386 :     *)
387 :    
388 :     val absyn2 =
389 :     LOCALdec(VALdec[VB{pat=TUPLEpat[VARpat basevar,
390 :     VARpat countarrayvar,
391 :     VARpat currentvar],
392 :     exp=APPexp(APPexp(VARexp(ref derefop,
393 :     [profDerefTy]),
394 :     varexp register),
395 :     STRINGexp(concat(rev(!entries)))),
396 :     tyvars=ref nil,
397 :     boundtvs=[]}],
398 :     absyn1)
399 :    
400 :     in absyn2
401 :     end
402 :    
403 :     fun instrumDec mrmto (env, compInfo) absyn =
404 :     if !SMLofNJ.Internals.ProfControl.profMode
405 :     then instrumDec' mrmto (env, compInfo) absyn
406 :     else absyn
407 :    
408 :     end (* local *)
409 :     end (* structure TProf *)
410 :    
411 :    

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