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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 592 - (view) (download)

1 : monnier 245 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* sprof.sml *)
3 :    
4 :     signature SPROF =
5 :     sig
6 :     val instrumDec : StaticEnv.staticEnv * CompBasic.compInfo ->
7 :     Source.inputSource -> Absyn.dec -> Absyn.dec
8 :    
9 :     end (* signature SPROF *)
10 :    
11 :    
12 :     structure SProf :> SPROF =
13 :     struct
14 :    
15 :     local structure SP = SymPath
16 :     structure V = VarCon
17 :     structure M = Modules
18 :     structure B = Bindings
19 :     structure P = PrimOp
20 :     open Absyn VarCon Types BasicTypes
21 :     in
22 :    
23 :     (*
24 :     * WARNING: THE MAIN CODE IS CURRENTLY TURNED OFF;
25 :     * we will merge in Chesakov's SProf in the future (ZHONG).
26 :     *)
27 :    
28 : blume 592 fun instrumDec (env,
29 : monnier 245 compInfo as {mkLvar, ...} : CompBasic.compInfo) source absyn = absyn
30 :    
31 :     (*
32 :    
33 :     infix -->
34 :     val xsym = Symbol.varSymbol "x"
35 :    
36 : blume 592 fun instrumDec env source absyn =
37 : monnier 245 if not(!SMLofNJ.Internals.ProfControl.sprofiling) then absyn
38 :     else let
39 :    
40 :     val namelist : string list ref = ref nil
41 :     val namecount = ref 0
42 :    
43 :     val alpha = IBOUND 0
44 :    
45 :     val entervar as VALvar{typ=entertyp,...} =
46 :     mkVALvar(Symbol.varSymbol "enter", LVAR(mkLvar()))
47 :     val _ = entertyp := POLYty{sign=[false],
48 :     tyfun = TYFUN{arity=1,
49 :     body=tupleTy[alpha,intTy] --> alpha}}
50 :    
51 :    
52 :     val enterexp = VARexp(ref entervar, [])
53 :    
54 :     fun clean names = names
55 :     val err = ErrorMsg.impossible
56 :    
57 :     fun enter((line_a,line_b),names,exp) =
58 :     let fun dot (a,[z]) = Symbol.name z :: a
59 :     | dot (a,x::rest) = dot("." :: Symbol.name x :: a, rest)
60 :     | dot _ = err "no path in instrexp"
61 :     val (fname,lineno_a,charpos_a) = Source.filepos source line_a
62 :     val (_,lineno_b,charpos_b) = Source.filepos source line_b
63 :     val position = [fname,":",Int.toString lineno_a,".",
64 :     Int.toString charpos_a,"-", Int.toString lineno_b, ".",
65 :     Int.toString charpos_b,":"]
66 :     val name = concat (position @ dot (["\n"], names))
67 :     val index = !namecount
68 :     in namecount := index + 1;
69 :     namelist := name :: !namelist;
70 :     APPexp(enterexp,
71 :     ElabUtil.TUPLEexp[exp, INTexp (Int.toString index, intTy)])
72 :     end
73 :    
74 :     fun instrdec (line, names, VALdec vbl) =
75 :     let fun instrvb (vb as VB{pat=VARpat(VALvar{access=PRIMOP _,...}),...}) =vb
76 :     | instrvb (vb as VB{pat=CONSTRAINTpat
77 :     (VARpat (VALvar{access=PRIMOP _,...}),_),...}) = vb
78 :     | instrvb (VB{pat as VARpat(VALvar{path=SP.SPATH[n],...}),
79 :     exp,tyvars,boundtvs}) =
80 :     VB{pat=pat,
81 :     exp=instrexp(line, n::clean names) exp,
82 :     tyvars=tyvars, boundtvs=boundtvs}
83 :     | instrvb (VB{pat as CONSTRAINTpat(VARpat(VALvar{path=SP.SPATH[n],...}),_),
84 :     exp,tyvars,boundtvs}) =
85 :     VB{pat=pat,
86 :     exp=instrexp(line, n::clean names) exp,
87 :     tyvars=tyvars, boundtvs=boundtvs}
88 :     | instrvb (VB{pat,exp,tyvars,boundtvs}) =
89 :     VB{pat=pat, exp=instrexp (line,names) exp, tyvars=tyvars,
90 :     boundtvs=boundtvs}
91 :     in VALdec (map instrvb vbl)
92 :     end
93 :    
94 :     | instrdec (line, names, VALRECdec rvbl) =
95 :     let fun instrrvb (RVB{var as VALvar{path=SP.SPATH[n],...},
96 :     exp,resultty,tyvars,boundtvs}) =
97 :     RVB{var=var,
98 :     exp=instrexp (line, n::clean names) exp,
99 :     resultty=resultty, tyvars=tyvars, boundtvs=boundtvs}
100 :     | instrrvb _ = err "VALRECdec in SProf.instrdec"
101 :     in VALRECdec(map instrrvb rvbl)
102 :     end
103 :     | instrdec(line, names, ABSTYPEdec {abstycs,withtycs,body}) =
104 :     ABSTYPEdec {abstycs=abstycs,withtycs=withtycs,
105 :     body=instrdec(line, names, body)}
106 :     | instrdec(line,names, STRdec strbl) =
107 :     STRdec (map (fn strb => instrstrb(line,names,strb)) strbl)
108 :     | instrdec(line,names, ABSdec strbl) =
109 :     ABSdec (map (fn strb => instrstrb(line,names,strb)) strbl)
110 :     | instrdec(line,names, FCTdec fctbl) =
111 :     FCTdec (map (fn fctb => instrfctb(line,names,fctb)) fctbl)
112 :     | instrdec(line,names, LOCALdec(localdec,visibledec)) =
113 :     LOCALdec(instrdec (line,names,localdec),
114 :     instrdec (line,names,visibledec))
115 :     | instrdec(line,names, SEQdec decl) =
116 :     SEQdec (map (fn dec => instrdec(line,names,dec)) decl)
117 :     | instrdec(line,names, MARKdec(dec,region)) =
118 :     MARKdec(instrdec (region,names,dec), region)
119 :     | instrdec(line,names, other) = other
120 :    
121 :     and (* instrstrexp(line, names, STRUCTstr {body,locations,str}) =
122 :     STRUCTstr{body = (map (fn dec => instrdec(line,names,dec)) body),
123 :     locations=locations,str=str}
124 :     | *) instrstrexp(line, names, APPstr {oper,arg,argtycs,res,restycs}) =
125 :     APPstr{oper=oper, arg=instrstrexp(line,names,arg),
126 :     argtycs=argtycs, res=res, restycs=restycs}
127 :     | instrstrexp(line, names, VARstr x) = VARstr x
128 :     | instrstrexp(line, names, LETstr(d,body)) =
129 :     LETstr(instrdec(line,names,d), instrstrexp(line,names,body))
130 :     | instrstrexp(line, names,MARKstr(body,region)) =
131 :     MARKstr(instrstrexp(region,names,body),region)
132 :    
133 :     and instrstrb (line, names, STRB{name, str, def}) =
134 :     STRB{str=str, def=instrstrexp(line, name::names, def), name=name}
135 :    
136 :     and instrfctb (line, names,
137 :     FCTB{fct, name, def=FCTfct{param, def=d, argtycs,
138 :     fct=f, restycs}}) =
139 :     FCTB{fct=fct, name=name,
140 :     def=FCTfct{param=param, def=instrstrexp(line, name::names, d),
141 :     fct=f, restycs=restycs, argtycs=argtycs}}
142 :     | instrfctb (line, names, fctb) = fctb
143 :    
144 :     and instrexp(line,names) =
145 :     let fun rule(RULE(p,e)) = RULE(p, iexp e)
146 :     and iexp (RECORDexp(l as _::_)) =
147 :     let fun field(lab,exp) = (lab, iexp exp)
148 :     in enter(line,Symbol.varSymbol(Int.toString(length l))::names,
149 :     RECORDexp(map field l))
150 :     end
151 :     | iexp (VECTORexp(l,t)) = VECTORexp((map iexp l),t)
152 :     | iexp (SEQexp l) = SEQexp(map iexp l)
153 :     | iexp (APPexp(f,a)) = APPexp(iexp f, iexp a)
154 :     | iexp (CONSTRAINTexp(e,t)) = CONSTRAINTexp(iexp e, t)
155 :     | iexp (HANDLEexp (e, HANDLER(FNexp(l,t)))) =
156 :     HANDLEexp(iexp e, HANDLER(FNexp(map rule l, t)))
157 :     | iexp (HANDLEexp (e, HANDLER h)) = HANDLEexp(iexp e, HANDLER(iexp h))
158 :     | iexp (RAISEexp(e,t)) = RAISEexp(iexp e, t)
159 :     | iexp (LETexp(d,e)) = LETexp(instrdec(line,names,d), iexp e)
160 :     | iexp (CASEexp(e,l,b)) = CASEexp(iexp e, map rule l, b)
161 :     | iexp (FNexp(l,t)) = enter(line,names,(FNexp(map rule l, t)))
162 :     | iexp (MARKexp(e,region)) = MARKexp(instrexp(region,names) e, region)
163 :     | iexp (e as CONexp(DATACON{rep,...},_)) =
164 :     (case rep
165 :     of (UNTAGGED | TAGGED _ | REF | EXNFUN _) => (*ZHONG?*)
166 :     etaexpand e
167 :     | _ => e)
168 :     | iexp e = e
169 :    
170 :     and etaexpand(e as CONexp(_,t)) =
171 :     let val v = VALvar{access=LVAR(mkLvar()),
172 :     path=SP.SPATH [xsym],
173 :     typ=ref Types.UNDEFty}
174 :     in FNexp([RULE(VARpat v,
175 :     enter(line,names,APPexp(e,VARexp(ref v, []))))],
176 :     Types.UNDEFty)
177 :     end
178 :     | etaexpand _ = err "etaexpand in sprof.sml"
179 :     in iexp
180 :     end
181 :    
182 :    
183 :     val derefop = VALvar{path = SP.SPATH [Symbol.varSymbol "!"],
184 :     access = PRIMOP P.DEREF,
185 :     typ = ref(POLYty{sign=[false],
186 :     tyfun = TYFUN{arity=1,
187 :     body=
188 :     CONty(refTycon,[alpha])
189 :     --> alpha}})}
190 :    
191 :     val registerTy =
192 :     POLYty{sign=[false],
193 :     tyfun = TYFUN{arity=1,
194 :     body= CONty(refTycon,[stringTy -->
195 :     (tupleTy[alpha,intTy]
196 :     --> alpha)])}}
197 :    
198 :     val V.VAL registerVar = Lookup.lookVal
199 : blume 592 (env,
200 :     SP.SPATH [CoreSym.coreSym, Symbol.varSymbol "profile_sregister"],
201 : monnier 245 fn _ => fn s => fn _ => err "222 in sprof")
202 :    
203 :     val absyn' =instrdec((0,0),nil,absyn)
204 :    
205 :     in
206 :     LOCALdec(VALdec[VB{pat=VARpat entervar,
207 :     exp=APPexp(APPexp(VARexp(ref derefop,[]),
208 :     VARexp(ref(registerVar),[])),
209 :     STRINGexp(concat(rev(!namelist)))),
210 :     tyvars=ref nil,
211 :     boundtvs=[]}], (* ZHONG? *)
212 :     absyn')
213 :    
214 :     end (* function instrumDec *)
215 :    
216 :     *)
217 :    
218 :     end (* local *)
219 :     end (* structure SProf *)
220 :    
221 :    

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