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 904 - (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 :     | exp as APPexp (f,a) =>
279 :     let fun safe(VARexp(ref(VALvar{info, ...}), _)) =
280 :     if II.isSimple info then
281 :     (if mayReturnMoreThanOnce info then false
282 :     else true)
283 :     else false
284 :     | safe(MARKexp(e,_)) = safe e
285 :     | safe(CONSTRAINTexp(e,_)) = safe e
286 :     | safe(SEQexp[e]) = safe e
287 :     | safe _ = false
288 :    
289 :     fun rator_instr a =
290 :     case a
291 :     of APPexp(randf,_) =>
292 :     if safe randf then iinstr else oinstr
293 :     | VARexp _ => oinstr
294 :     | MARKexp(e,_) => rator_instr e
295 :     | CONSTRAINTexp(e,_) => rator_instr e
296 :     | SEQexp[e] => rator_instr e
297 :     | _ => iinstr
298 :    
299 :     val f' = rator_instr a f
300 :    
301 :     in if tail orelse (safe f)
302 :     then APPexp (f', oinstr a)
303 :     else let val ty = Reconstruct.expType exp
304 :     val lvar = tmpvar("appvar",ty,mkv)
305 :     in LETexp (VALdec[VB{pat=VARpat(lvar),
306 :     exp=APPexp(f', oinstr a),
307 :     tyvars=ref nil,
308 :     boundtvs=[]}],
309 :     SEQexp([SETCURRENTexp(ccvara),
310 :     varexp lvar]))
311 :     end
312 :     end
313 :    
314 :     | CONSTRAINTexp(e,t) => CONSTRAINTexp(instr e, t)
315 :    
316 :     | HANDLEexp (e, HANDLER(FNexp(l,t)))=>
317 :     let fun rule(RULE(p,e)) =
318 :     RULE(p,SEQexp[SETCURRENTexp ccvara, instr e])
319 :     in HANDLEexp (instr e, HANDLER(FNexp(map rule l,t)))
320 :     end
321 :    
322 :     | RAISEexp(e, t) => RAISEexp(oinstr e, t)
323 :    
324 :     | LETexp (d, e) => LETexp (instrdec(sp,d), instr e)
325 :    
326 :     | PACKexp(e, t, tycs) => PACKexp(oinstr e, t, tycs)
327 :    
328 :     | CASEexp (e, l, b) =>
329 :     CASEexp(iinstr e, instrrules instr l, b)
330 :    
331 :     | FNexp(l,t) =>
332 :     let fun dot (a,[z]) = S.name z :: a
333 :     | dot (a,x::rest) =
334 :     dot("." :: S.name x :: a, rest)
335 :     | dot _ = bug "no path in instrexp"
336 :    
337 :     val name = concat (dot ([], names))
338 :     val ccvara' = makeEntry(name)
339 :     val lvar = tmpvar("fnvar",t,mkv);
340 :    
341 : blume 904 val exnMatch = CoreAccess.getCon (env, "Match")
342 : blume 903
343 :     val RULE(_,special) = List.last l
344 :     in FNexp ([RULE(VARpat(lvar),
345 :     SEQexp ([BUMPCCexp(ccvara'),
346 :     SETCURRENTexp(ccvara'),
347 :     CASEexp(varexp lvar,
348 :     instrrules (instrexp (anonSym::names,
349 :     ccvara') true) l,
350 :     true)])),
351 :     RULE(WILDpat,RAISEexp(CONexp(exnMatch,[]),
352 :     Reconstruct.expType special))
353 :     ], t)
354 :     end
355 :     | MARKexp(e,region) => MARKexp(instr e, region)
356 :     | e => e
357 :    
358 :     in instr
359 :     end
360 :     in istail
361 :     end (* function instrexp *)
362 :    
363 :     val absyn1 = instrdec(([],0),absyn)
364 :    
365 :     (*
366 :     * The following break the invariant set in the absyn.sml where
367 :     * the pat in each VB binding should bind single variables !;
368 :     * The following VB only binds monomorphic variables, so it is
369 :     * probably ok for the time being. We definitely should clean it
370 :     * up some time in the future. (ZHONG)
371 :     *)
372 :    
373 :     val absyn2 =
374 :     LOCALdec(VALdec[VB{pat=TUPLEpat[VARpat basevar,
375 :     VARpat countarrayvar,
376 :     VARpat currentvar],
377 :     exp=APPexp(APPexp(VARexp(ref derefop,
378 :     [profDerefTy]),
379 :     varexp register),
380 :     STRINGexp(concat(rev(!entries)))),
381 :     tyvars=ref nil,
382 :     boundtvs=[]}],
383 :     absyn1)
384 :    
385 :     in absyn2
386 :     end
387 :    
388 :     fun instrumDec mrmto (env, compInfo) absyn =
389 :     if !SMLofNJ.Internals.ProfControl.profMode
390 :     then instrumDec' mrmto (env, compInfo) absyn
391 :     else absyn
392 :    
393 :     end (* local *)
394 :     end (* structure TProf *)
395 :    
396 :    

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