![[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.