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/branches/primop-branch-3/compiler/DebugProf/profile/tprof.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/compiler/DebugProf/profile/tprof.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3344 - (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 : blume 2222 (PrimOpId.primId -> bool) ->
11 : blume 903 (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 : blume 2222 in VALvar{access=A.namedAcc(sym, mkv), prim=PrimOpId.NonPrim,
94 : gkuan 3229 path=SP.SPATH[sym], btvs = ref [], typ=ref ty}
95 : blume 903 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 : dbm 2636 let fun getVar name = CoreAccess.getVar env [name]
109 : blume 903 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 : dbm 2636 val register = getVar "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 : blume 2222 in APPexp(VARexp(ref updateop, [ref(INSTANTIATED(intTy))]),
152 : blume 903 TUPLEexp[countarray,
153 :     INTexp (IntInf.fromInt ccvara, intTy),
154 :     APPexp(varexp addop,
155 : blume 2222 TUPLEexp[APPexp(VARexp(ref subop,[ref(INSTANTIATED(intTy))]),
156 : blume 903 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 : blume 2222 APPexp(VARexp(ref assignop,[ref(INSTANTIATED(intTy))]),
173 : blume 903 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 : blume 2222 of SOME(VALvar{prim, path=SP.SPATH[n],...}) =>
184 :     (case prim
185 :     of PrimOpId.NonPrim => vb
186 :     | _ => VB{pat=pat, tyvars=tyvars,
187 :     exp=instrexp (n::clean names,
188 :     ccvara) false exp,
189 :     boundtvs=boundtvs})
190 :     | SOME(VALvar{prim, ...}) =>
191 :     (case prim
192 :     of PrimOpId.NonPrim => vb
193 :     | _ => VB{pat=pat, exp=instrexp sp false exp,
194 :     tyvars=tyvars, boundtvs=boundtvs})
195 : blume 903 | _ => VB{pat=pat, exp=instrexp sp false exp,
196 :     tyvars=tyvars, boundtvs=boundtvs})
197 :    
198 :     in VALdec (map instrvb vbl)
199 :     end
200 :    
201 :     | instrdec(sp as (names,ccvara), VALRECdec rvbl) =
202 :     let fun instrrvb (RVB{var as VALvar{path=SP.SPATH[n],...},
203 :     exp,resultty,tyvars,boundtvs}) =
204 :     RVB{exp=instrexp(n::clean names, ccvara) false exp,
205 :     var=var, resultty=resultty, tyvars=tyvars,
206 :     boundtvs=boundtvs}
207 :    
208 :     | instrrvb _ = bug "VALRECdec in instrdec"
209 :     in VALRECdec(map instrrvb rvbl)
210 :     end
211 :    
212 :     | instrdec(sp, ABSTYPEdec {abstycs,withtycs,body}) =
213 :     ABSTYPEdec {abstycs=abstycs,withtycs=withtycs,
214 :     body=instrdec(sp,body)}
215 :    
216 :     | instrdec(sp, STRdec strbl) =
217 :     STRdec (map (fn strb => instrstrb(sp,strb)) strbl)
218 :    
219 :     | instrdec(sp, FCTdec fctbl) =
220 :     FCTdec (map (fn fctb => instrfctb(sp,fctb)) fctbl)
221 :    
222 :     | instrdec(sp, LOCALdec(localdec,visibledec)) =
223 :     LOCALdec(instrdec (sp,localdec), instrdec (sp,visibledec))
224 :    
225 :     | instrdec(sp, SEQdec decl) =
226 :     SEQdec (map (fn dec => instrdec(sp,dec)) decl)
227 :    
228 :     | instrdec(sp, MARKdec(dec,region)) =
229 :     MARKdec(instrdec (sp,dec), region)
230 :    
231 :     | instrdec(sp, other) = other
232 :    
233 :     and instrstrexp(names, LETstr(d,body)) =
234 :     LETstr(instrdec((names,0),d), instrstrexp(names,body))
235 :    
236 :     | instrstrexp(names,MARKstr(body,region)) =
237 :     MARKstr(instrstrexp(names,body),region)
238 :    
239 :     | instrstrexp(names, x) = x
240 :    
241 :     and instrstrb ((names,ccvara), STRB{name, str, def}) =
242 :     STRB{str=str, def=instrstrexp(name::names,def), name=name}
243 :    
244 : gkuan 3344 and instrfctexp(names, FCTfct {param, def, primaries}) =
245 :     FCTfct{param=param, def=instrstrexp(names,def), primaries=primaries}
246 : blume 903
247 :     | instrfctexp(names, LETfct(d,body)) =
248 :     LETfct(instrdec((names,0),d), instrfctexp(names,body))
249 :    
250 :     | instrfctexp(names,MARKfct(body,region)) =
251 :     MARKfct(instrfctexp(names,body),region)
252 :    
253 :     | instrfctexp(names, x) = x
254 :    
255 :     and instrfctb ((names,ccvara), FCTB{name, fct, def}) =
256 :     FCTB{name=name, fct=fct, def=instrfctexp(name::names,def)}
257 :    
258 :     and instrexp(sp as (names,ccvara)) =
259 :     let fun istail tail =
260 :     let fun iinstr exp = istail false exp
261 :     fun oinstr exp = istail true exp
262 :     fun instrrules tr = map (fn (RULE(p,e)) => RULE(p, tr e))
263 :    
264 :     val rec instr:(exp->exp) =
265 :     fn RECORDexp l =>
266 :     RECORDexp(map (fn (lab,exp) => (lab,iinstr exp)) l)
267 :    
268 :     | VECTORexp(l,t) => VECTORexp((map iinstr l),t)
269 :    
270 :     | SEQexp l =>
271 :     let fun seq [e] = [instr e]
272 :     | seq (e::r) = (iinstr e)::(seq r)
273 :     | seq nil = nil
274 :     in SEQexp (seq l)
275 :     end
276 :    
277 : mblume 1332 | IFexp { test, thenCase, elseCase } =>
278 :     IFexp { test = iinstr test,
279 :     thenCase = instr thenCase,
280 :     elseCase = instr elseCase }
281 :    
282 :     | ANDALSOexp (e1, e2) =>
283 :     ANDALSOexp (iinstr e1, instr e2)
284 :     | ORELSEexp (e1, e2) =>
285 :     ORELSEexp (iinstr e1, instr e2)
286 :     | WHILEexp { test, expr } =>
287 :     WHILEexp { test = iinstr test, expr = iinstr expr }
288 :    
289 : blume 903 | exp as APPexp (f,a) =>
290 : blume 2222 let fun safe(VARexp(ref(VALvar{prim, ...}), _)) =
291 :     (case prim
292 :     of PrimOpId.NonPrim => false
293 :     | _ =>
294 :     if mayReturnMoreThanOnce prim then false
295 :     else true)
296 : blume 903 | 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 : mblume 1641 | HANDLEexp (e, (l,t)) =>
329 : blume 903 let fun rule(RULE(p,e)) =
330 :     RULE(p,SEQexp[SETCURRENTexp ccvara, instr e])
331 : mblume 1641 in HANDLEexp (instr e, (map rule l,t))
332 : blume 903 end
333 :    
334 :     | RAISEexp(e, t) => RAISEexp(oinstr e, t)
335 :    
336 :     | LETexp (d, e) => LETexp (instrdec(sp,d), instr e)
337 :    
338 : gkuan 2730 (*| PACKexp(e, t, tycs) => PACKexp(oinstr e, t, tycs)*)
339 : blume 903
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 : dbm 2636 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 : blume 2222 [ref(INSTANTIATED(profDerefTy))]),
391 : blume 903 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