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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 419 - (view) (download)

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

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