![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to prof.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / build|
Return to prof.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / build |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: signature PROF = sig
3: type profileInfo
4: val instrumDec : Absyn.dec -> (Absyn.dec * profileInfo)
5: val instrumStrb : Absyn.strb -> (Absyn.strb * profileInfo)
6: val instrumFctb : Absyn.fctb -> (Absyn.fctb * profileInfo)
7: val bindLambda : (Lambda.lexp * profileInfo) -> Lambda.lexp
8: end
9:
10: abstraction Prof : PROF =
11: struct
12:
13: open Access Absyn Lambda Basics BasicTypes ErrorMsg
14:
15: type profileInfo = (lvar * string) list
16:
17: val symbol = Symbol.symbol
18:
19: (* Profiling globals *)
20: val profiling = System.Control.Profile.profiling
21: val profileList = ref([]: (Access.lvar * string) list)
22:
23: val anonSym = symbol "anon"
24:
25: val intreftype = CONty(refTycon,[intTy])
26: val alpha = VARty(mkTyvar(IBOUND 0))
27:
28: fun topCCa() = VALvar{name = [symbol "toplevel.CC"],
29: access = PATH(!CoreInfo.toplevelPath),
30: typ = ref intreftype}
31: val assop = VALvar{name = [symbol "unboxedassign"],
32: access = INLINE P.unboxedassign,
33: typ = ref(tupleTy[intreftype,intTy] --> unitTy)}
34: val derefop = VALvar{name = [symbol "!"],
35: access = INLINE P.!,
36: typ = ref(CONty(refTycon,[alpha]) --> alpha)}
37: val addop = VALvar{name = [symbol "iadd"],
38: access = INLINE P.+,
39: typ = ref(tupleTy[intTy,intTy] --> intTy)}
40: fun currentvar() = VALvar{name = [symbol "current"],
41: access = PATH(!CoreInfo.currentPath),
42: typ = ref intreftype}
43:
44: fun tmpvar str =
45: let val lvar = mkLvar()
46: val name = [symbol str]
47: in (VALvar{name=name, access=LVAR(lvar), typ = ref UNDEFty},
48: VALvar{name=name, access=PATH[lvar], typ = ref UNDEFty})
49: end
50:
51: fun clean (path as name::names) = if Symbol.eq(name,anonSym) then names else path
52: | clean x = x
53:
54: fun instrdec(sp as (names,ccvara), VALdec vbl) =
55: let fun instrvb (vb as VB{pat=VARpat(VALvar{access=INLINE _,...}),...}) = vb
56: | instrvb (vb as VB{pat=CONSTRAINTpat
57: (VARpat (VALvar{access=INLINE _,...}),_),...}) = vb
58: | instrvb (VB{pat as VARpat(VALvar{access=LVAR v,name=[n],...}),exp,tyvars}) =
59: VB{pat=pat,exp=instrexp(n::clean names,ccvara)false exp,
60: tyvars=tyvars}
61: | instrvb (VB{pat,exp,tyvars}) =
62: VB{pat=pat, exp=instrexp sp false exp, tyvars=tyvars}
63: in VALdec (map instrvb vbl)
64: end
65: | instrdec(sp as (names,ccvara), VALRECdec rvbl) =
66: let fun instrrvb (RVB{var=var as VALvar{access=LVAR v, name=[n],...},
67: exp,resultty,tyvars}) =
68: RVB{var=var, exp=instrexp (n::clean names, ccvara) false exp,
69: resultty=resultty, tyvars=tyvars}
70: | instrrvb _ = impossible "VALRECdec in instrdec"
71: in VALRECdec(map instrrvb rvbl)
72: end
73: | instrdec(sp, ABSTYPEdec {abstycs,withtycs,body}) =
74: ABSTYPEdec {abstycs=abstycs,withtycs=withtycs, body=instrdec(sp,body)}
75: | instrdec(sp, STRdec strbl) = STRdec (map (fn strb => instrstrb(sp,strb)) strbl)
76: | instrdec(sp, ABSdec strbl) = ABSdec (map (fn strb => instrstrb(sp,strb)) strbl)
77: | instrdec(sp, FCTdec fctbl) = FCTdec (map (fn fctb => instrfctb(sp,fctb)) fctbl)
78: | instrdec(sp, LOCALdec(localdec,visibledec)) =
79: LOCALdec(instrdec (sp,localdec), instrdec (sp,visibledec))
80: | instrdec(sp, SEQdec decl) = SEQdec (map (fn dec => instrdec(sp,dec)) decl)
81: | instrdec(sp, MARKdec(dec,a,b)) = MARKdec(instrdec (sp,dec), a,b)
82: | instrdec(sp, other) = other
83:
84: and instrstrexp(names, STRUCTstr {body,locations}) =
85: STRUCTstr{body = (map (fn dec => instrdec((names,topCCa()),dec)) body),
86: locations=locations}
87: | instrstrexp(names, APPstr {oper,argexp,argthin}) =
88: APPstr{oper=oper, argexp=instrstrexp(names,argexp),argthin=argthin}
89: | instrstrexp(names, VARstr x) = VARstr x
90: | instrstrexp(names, LETstr(d,body)) =
91: LETstr(instrdec((names,topCCa()),d), instrstrexp(names,body))
92:
93: and instrstrb ((names,ccvara), STRB{strvar=strvar as STRvar{name,...},
94: def,thin,constraint}) =
95: STRB{strvar=strvar,def = instrstrexp(name@names,def),
96: thin=thin, constraint=constraint}
97:
98: and instrfctb ((names,ccvara), FCTB{fctvar=fctvar as FCTvar{name,...},
99: param,def,thin,constraint}) =
100: FCTB{fctvar=fctvar,param=param,def=instrstrexp(name::names,def),
101: thin=thin, constraint=constraint}
102:
103: and instrexp(sp as (names,ccvara)) =
104: let fun istail tail =
105: let fun iinstr exp = istail false exp
106: fun oinstr exp = istail true exp
107: fun instrrules tr = map (fn (RULE(p,e)) => RULE(p, tr e))
108: fun BUMPCCexp ccvara =
109: APPexp(VARexp(ref assop),
110: TUPLEexp[VARexp(ref ccvara),
111: APPexp(VARexp(ref addop),
112: TUPLEexp[APPexp(VARexp(ref derefop),
113: VARexp(ref ccvara)),
114: INTexp(1)])])
115: fun SETCURRENTexp ccvara =
116: APPexp(VARexp(ref assop),
117: TUPLEexp[VARexp(ref (currentvar())), VARexp(ref ccvara)])
118: val rec instr:(exp->exp) =
119: fn RECORDexp l => RECORDexp(map (fn (lab,exp) => (lab,iinstr exp)) l)
120: | SEQexp l =>
121: let fun seq [e] = [instr e]
122: | seq (e::r) = (iinstr e)::(seq r)
123: | seq nil = nil
124: in SEQexp (seq l)
125: end
126: | APPexp (f,a) =>
127: let fun safe(VARexp(ref(VALvar{access=INLINE P.callcc,...})))=false
128: | safe(VARexp(ref(VALvar{access=INLINE _,...}))) = true
129: | safe _ = false
130: in if tail orelse (safe f)
131: then APPexp (iinstr f, iinstr a)
132: else let val (lvarb,lvara) = tmpvar("appvar")
133: in LETexp (VALdec[VB{pat=VARpat(lvarb),
134: exp=APPexp(iinstr f, iinstr a),
135: tyvars=nil}],
136: SEQexp([SETCURRENTexp(ccvara), VARexp(ref lvara)]))
137: end
138: end
139: | CONSTRAINTexp(e,t) => CONSTRAINTexp(instr e, t)
140: | HANDLEexp (e, HANDLER(FNexp l))=>
141: let fun rule(RULE(p,e)) =
142: RULE(p,SEQexp[SETCURRENTexp ccvara, instr e])
143: in HANDLEexp (instr e, HANDLER(FNexp(map rule l)))
144: end
145: | RAISEexp e => RAISEexp(oinstr e)
146: | LETexp (d,e) => LETexp (instrdec(sp,d), instr e)
147: | CASEexp (e,l) => CASEexp(iinstr e, instrrules instr l)
148: | FNexp l =>
149: let fun dot (a,[z]) = Symbol.name z :: a
150: | dot (a,x::rest) = dot("." :: Symbol.name x :: a, rest)
151: | dot _ = impossible "no path in instrexp"
152: val name = implode (dot ([], names))
153: val ccsym = symbol (name^".CC")
154: val ccvar = namedLvar(ccsym)
155: val ccvara' = VALvar{name=[ccsym],
156: access=PATH[ccvar],
157: typ = ref intreftype}
158: val (lvarb,lvara) = tmpvar "fnvar";
159: in profileList := (ccvar,name) :: !profileList;
160: FNexp ([RULE(VARpat(lvarb),
161: SEQexp ([BUMPCCexp(ccvara'),
162: SETCURRENTexp(ccvara'),
163: CASEexp(VARexp(ref lvara),
164: instrrules (instrexp (anonSym::names,
165: ccvara') true) l)]))])
166: end
167: | MARKexp(e,a,b) => MARKexp(instr e, a, b)
168: | e => e
169: in instr
170: end
171: in istail
172: end
173:
174: fun instrumDec absyn =
175: (profileList := [];
176: (if !profiling then instrdec(([],topCCa()),absyn) else absyn, !profileList))
177:
178: fun instrumStrb absyn =
179: (profileList := [];
180: (if !profiling then instrstrb(([],topCCa()),absyn) else absyn, !profileList))
181:
182: fun instrumFctb absyn =
183: (profileList := [];
184: (if !profiling then instrfctb(([],topCCa()),absyn) else absyn, !profileList))
185:
186: fun bindLambda (lexp, profileList) =
187: fold (fn ((var,string),x) => APP(FN(var,x),STRING("aaaaaaaa"^string)))
188: profileList
189: (RECORD[lexp,RECORD(map (VAR o #1) profileList)])
190:
191: end (* structure Instrum *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.