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/Semant/modules/evalent.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Semant/modules/evalent.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 587 - (view) (download)

1 : monnier 249 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* evalent.sml *)
3 :    
4 :     signature EVALENTITY =
5 :     sig
6 :    
7 :     val evalApp : Modules.fctEntity * Modules.strEntity
8 :     * DebIndex.depth * EntPathContext.context
9 :     * InvPath.path * ElabUtil.compInfo
10 :     -> Modules.strEntity
11 :    
12 :     val debugging : bool ref
13 :    
14 :     end (* signature EVALENTITY *)
15 :    
16 :     structure EvalEntity : EVALENTITY =
17 :     struct
18 :    
19 :     local structure DI = DebIndex
20 :     structure EP = EntPath
21 :     structure IP = InvPath
22 :     structure S = SourceMap
23 :     structure T = Types
24 :     structure EE = EntityEnv
25 :     structure EPC = EntPathContext
26 :     structure EU = ElabUtil
27 :     structure I = Instantiate
28 :     structure MI = ModuleId
29 :     structure MU = ModuleUtil
30 :     open Modules
31 :     in
32 :    
33 :     (* debugging *)
34 :     val say = Control.Print.say
35 :     val debugging = Control.CG.eedebugging
36 :     fun debugmsg (msg: string) =
37 :     if !debugging then (say msg; say "\n") else ()
38 :    
39 :     open ElabDebug
40 :    
41 :     val debugPrint = (fn x => debugPrint debugging x) (* Value Restriction *)
42 :     fun bug msg = ErrorMsg.impossible ("EvalEntity: " ^ msg);
43 :     val anonFctSym = Symbol.fctSymbol "AnonFct"
44 :     val paramSym = Symbol.strSymbol "<FsigParamInst>"
45 :     val anonStrSym = Symbol.strSymbol "<AnonStr>"
46 :     val resultId = Symbol.strSymbol "<resultStr>"
47 :     val returnId = Symbol.strSymbol "<returnStr>"
48 :    
49 :     val defaultError =
50 :     ErrorMsg.errorNoFile(ErrorMsg.defaultConsumer(),ref false) (0,0)
51 :    
52 :     fun evalTyc (entv, tycExp, entEnv, epc, rpath,
53 :     compInfo as {mkStamp,...}: EU.compInfo) =
54 :     case tycExp
55 :     of CONSTtyc tycon => tycon
56 : blume 587 | FORMtyc (T.GENtyc { kind, arity, eq, path, ... }) =>
57 :     (case kind of
58 :     T.DATATYPE{index=0, stamps, freetycs, family, root=NONE} =>
59 :     let val viztyc = MU.transTycon entEnv
60 :     val nstamps = Vector.map (fn _ => mkStamp()) stamps
61 :     val nst = Vector.sub(nstamps,0)
62 :     val nfreetycs = map viztyc freetycs
63 :     val _ = EPC.bindTycPath (epc, nst, entv)
64 :     in
65 :     T.GENtyc{stamp=nst, arity=arity, eq=eq,
66 :     kind=T.DATATYPE{index=0, stamps=nstamps,
67 :     root=NONE,
68 :     freetycs=nfreetycs,
69 :     family=family},
70 :     path=IP.append(rpath,path), stub=NONE}
71 :     end
72 :     | T.DATATYPE{index=i, root=SOME rtev, ...} =>
73 :     let val (nstamps, nfreetycs, nfamily) =
74 :     case EE.lookTycEnt(entEnv, rtev)
75 :     of T.GENtyc { kind = T.DATATYPE dt, ... } =>
76 :     (#stamps dt, #freetycs dt, #family dt)
77 :     | _ => bug "unexpected case in evalTyc-FMGENtyc (2)"
78 :     val nst = Vector.sub(nstamps,i)
79 :     val _ = EPC.bindTycPath (epc, nst, entv)
80 :     in
81 :     T.GENtyc{stamp=nst, arity=arity,
82 :     kind=T.DATATYPE{index=i, stamps=nstamps,
83 :     root=NONE,
84 :     freetycs=nfreetycs,
85 :     family=nfamily},
86 :     path=IP.append(rpath,path),
87 :     eq=eq, stub=NONE}
88 :     end
89 :     | _ => bug "unexpected GENtyc in evalTyc")
90 : monnier 249 | FORMtyc (T.DEFtyc{stamp,tyfun=T.TYFUN{arity, body},strict,path}) =>
91 : blume 587 let val nst = mkStamp()
92 :     (* tycId=stamp (this should perhaps be more abstract some day) *)
93 :     val _ = EPC.bindTycPath (epc, nst, entv)
94 :     in
95 :     T.DEFtyc{stamp = nst,
96 :     tyfun=T.TYFUN{arity=arity,
97 :     body=MU.transType entEnv body},
98 :     strict=strict, path=IP.append(rpath,path)}
99 :     end
100 : monnier 249 | VARtyc entPath =>
101 :     (debugmsg (">>evalTyc[VARtyc]: "^EP.entPathToString entPath);
102 :     EE.lookTycEP(entEnv,entPath))
103 :     | _ => bug "unexpected tycExp in evalTyc"
104 :    
105 :     and evalStr(strExp, depth, epc, entsv, entEnv, rpath,
106 :     compInfo as {mkStamp,...}: EU.compInfo) =
107 :     (debugmsg ("[Inside EvalStr ......");
108 :     case strExp
109 :     of VARstr entPath =>
110 :     (debugmsg (">>evalStr[VARstr]: "^EP.entPathToString entPath);
111 :     (EE.lookStrEP(entEnv,entPath), entEnv))
112 :    
113 :     | CONSTstr strEnt => (strEnt, entEnv)
114 :    
115 :     | STRUCTURE {stamp, entDec} =>
116 :     let val epc = EPC.enterOpen(epc, entsv)
117 :     val stp = evalStp(stamp, depth, epc, entEnv, compInfo)
118 :     val env = evalDec(entDec, depth, epc, entEnv, rpath, compInfo)
119 : blume 587 in
120 :     ({stamp = stp, entities=env, lambdaty=ref NONE,
121 :     rpath = rpath, stub = NONE},
122 :     entEnv)
123 : monnier 249 end
124 :    
125 :     | APPLY (fctExp, strExp) =>
126 :     let val (fctRlzn, entEnv1) =
127 :     evalFct(fctExp, depth, epc, entEnv, compInfo)
128 :     val (argRlzn, entEnv2) =
129 :     evalStr(strExp, depth, epc, entsv, entEnv1,
130 :     IP.empty, compInfo)
131 :     val epc = EPC.enterOpen(epc, entsv)
132 :     in (evalApp(fctRlzn, argRlzn, depth, epc, rpath, compInfo),
133 :     entEnv2)
134 :     end
135 :    
136 :     | LETstr (entDec, strExp) =>
137 :     let val entEnv1 = evalDec(entDec, depth, epc,
138 :     entEnv, rpath, compInfo)
139 :     val (strEnt, entEnv2) =
140 :     evalStr(strExp, depth, epc, entsv, entEnv1,
141 :     rpath, compInfo)
142 :    
143 :     in (strEnt, entEnv2)
144 :     end
145 :    
146 :     | ABSstr (sign, strExp) =>
147 :     let val (srcRlzn, entEnv1) =
148 :     evalStr(strExp, depth, epc, entsv, entEnv, rpath, compInfo)
149 :     val {rlzn=rlzn, abstycs=abstycs, tyceps=tyceps} =
150 :     I.instAbstr{sign=sign, entEnv=entEnv, srcRlzn=srcRlzn,
151 :     rpath=rpath,
152 :     region=S.nullRegion, compInfo=compInfo}
153 :    
154 :     (* because the abstraction creates a bunch of new stamps,
155 :     we have to bind them to the epcontext.
156 :     *)
157 :     val epc = EPC.enterOpen(epc, entsv)
158 : blume 587 fun h (T.GENtyc gt, ep) =
159 :     EPC.bindTycLongPath (epc, MI.tycId gt, ep)
160 : monnier 249 | h _ = ()
161 :     val _ = ListPair.app h (abstycs, tyceps)
162 :     in (rlzn, entEnv1)
163 :     end
164 :    
165 :     | CONSTRAINstr {boundvar,raw,coercion} =>
166 :     (* propagage the context rpath into the raw uncoerced structure *)
167 :     let val (rawEnt, entEnv1) =
168 :     evalStr(raw, depth, epc, SOME boundvar,
169 :     entEnv, rpath, compInfo)
170 :     val entEnv2 = EE.bind(boundvar, STRent rawEnt, entEnv1)
171 :     (* val entEnv' = EE.bind(boundvar, STRent rawEnt, entEnv) *)
172 :     val (strEnt, entEnv3) =
173 :     evalStr(coercion, depth, epc, entsv,
174 :     entEnv2, IP.empty, compInfo)
175 :    
176 :     in (strEnt, entEnv3)
177 :     end
178 :    
179 :     | FORMstr _ => bug "unexpected FORMstr in evalStr")
180 :    
181 :    
182 :     and evalFct (fctExp, depth, epc, entEnv,
183 :     compInfo as {mkStamp,...}: EU.compInfo) =
184 :     case fctExp
185 :     of VARfct entPath =>
186 :     (debugmsg (">>evalFct[VARfct]: "^EP.entPathToString entPath);
187 :     (EE.lookFctEP(entEnv,entPath), entEnv))
188 :    
189 :     | CONSTfct fctEntity => (fctEntity, entEnv)
190 :    
191 :     | LAMBDA{param, body} =>
192 :     let val clos = CLOSURE{param=param, body=body, env=entEnv}
193 : blume 587 in ({stamp = mkStamp (),
194 :     closure=clos, lambdaty=ref NONE,
195 :     tycpath=NONE,
196 :     rpath=IP.IPATH[anonFctSym],
197 :     stub=NONE},
198 :     entEnv)
199 : monnier 249 end
200 :    
201 :     | LAMBDA_TP{param, body, sign as FSIG{paramsig, bodysig, ...}} =>
202 :     let val clos = CLOSURE{param=param, body=body, env=entEnv}
203 :     val tps =
204 :     let val rpath' = IP.IPATH [paramSym]
205 :     val {rlzn=paramEnt, tycpaths=paramTps} =
206 :     I.instParam{sign=paramsig, entEnv=entEnv,
207 :     rpath=rpath', depth=depth,
208 :     region=S.nullRegion, compInfo=compInfo}
209 :     val entEnv' =
210 :     EE.mark(mkStamp, EE.bind(param, STRent paramEnt,
211 :     entEnv))
212 :     val (bodyRlzn,_) =
213 :     evalStr(body, DI.next depth, epc, NONE,
214 :     entEnv', IP.empty, compInfo)
215 :     val bodyTps =
216 :     I.getTycPaths{sign=bodysig, rlzn=bodyRlzn,
217 :     entEnv=entEnv', compInfo=compInfo}
218 :     in T.TP_FCT(paramTps, bodyTps)
219 :     end
220 :    
221 : blume 587 in ({stamp = mkStamp(),
222 :     closure=clos, lambdaty=ref NONE,
223 :     tycpath=SOME tps, rpath=IP.IPATH[anonFctSym],
224 :     stub = NONE},
225 :     entEnv)
226 : monnier 249 end
227 :    
228 :     | LETfct (entDec, fctExp) =>
229 :     let val entEnv1 = evalDec(entDec, depth, epc,
230 :     entEnv, IP.empty, compInfo)
231 :     val (fctEnt, entEnv2) =
232 :     evalFct(fctExp, depth, epc, entEnv1, compInfo)
233 :     in (fctEnt, entEnv2)
234 :     end
235 :    
236 :     | _ => bug "unexpected cases in evalFct"
237 :    
238 : blume 587 and evalApp(fctRlzn : Modules.fctEntity, argRlzn, depth, epc, rpath,
239 : monnier 249 compInfo as {mkStamp, ...} : EU.compInfo) =
240 : blume 587 let val {closure=CLOSURE{param, body, env}, tycpath, ...} = fctRlzn
241 :     val nenv = EE.mark(mkStamp, EE.bind(param, STRent argRlzn, env))
242 : monnier 249 val _ = debugmsg ("[Inside EvalAPP] ......")
243 :     in case (body, tycpath)
244 :     of (FORMstr(FSIG{paramsig, bodysig, ...}), SOME tp) =>
245 :     let val argTps = I.getTycPaths{sign=paramsig, rlzn=argRlzn,
246 :     entEnv=env, compInfo=compInfo}
247 :     val resTp = T.TP_APP(tp, argTps)
248 :    
249 :     (** failing to add the stamps into the epcontext is
250 :     a potential bug here. Will fix this in the
251 :     future. ZHONG **)
252 :    
253 :     val {rlzn=rlzn, abstycs=abstycs, tyceps=tyceps} =
254 :     I.instFmBody {sign=bodysig, entEnv=nenv, tycpath=resTp,
255 :     rpath=rpath, region=S.nullRegion,
256 :     compInfo=compInfo}
257 :    
258 : blume 587 fun h (T.GENtyc gt, ep) =
259 :     EPC.bindTycLongPath (epc, MI.tycId gt, ep)
260 : monnier 249 | h _ = ()
261 :     val _ = ListPair.app h (abstycs, tyceps)
262 :     in rlzn
263 :     end
264 :     | _ =>
265 :     let val (strEnt, deltaEE)
266 :     = evalStr(body, depth, epc, NONE, nenv, rpath, compInfo)
267 :     (* invariant: deltaEE should always be same as nenv
268 :     if the body of an functor is always a BaseStr. Notice
269 :     functor body is constructed either in the source
270 :     programs (ml.grm) or in the elabmod.sml when dealing
271 :     with curried functor applications.
272 :     *)
273 :     in strEnt
274 :     end
275 :     end
276 :    
277 :     and evalDec(dec, depth, epc, entEnv, rpath,
278 :     compInfo as {mkStamp,...}: EU.compInfo) =
279 :     (debugmsg ("[Inside EvalDec ......");
280 :     case dec
281 :     of TYCdec (entVar, tycExp) =>
282 :     let val tycEnt =
283 :     evalTyc(entVar, tycExp, entEnv, epc, rpath, compInfo)
284 :     in EE.bind(entVar, TYCent tycEnt, entEnv)
285 :     end
286 :     | STRdec (entVar, strExp, sym) =>
287 :     let val rpath' =
288 :     if Symbol.eq(sym, returnId)
289 :     orelse Symbol.eq(sym, resultId)
290 :     then rpath
291 :     else IP.extend(rpath,sym)
292 :     val (strEnt, entEnv1) =
293 :     evalStr(strExp, depth, epc, SOME entVar,
294 :     entEnv, rpath', compInfo)
295 :     in EE.bind(entVar, STRent strEnt, entEnv1)
296 :     end
297 :    
298 :     | FCTdec (entVar, fctExp) =>
299 :     let val (fctEnt, entEnv1) =
300 :     evalFct(fctExp, depth, epc, entEnv, compInfo)
301 :     in EE.bind(entVar, FCTent fctEnt, entEnv1)
302 :     end
303 :     | SEQdec decs =>
304 :     let fun h (dec, entEnv0) =
305 :     evalDec(dec, depth, epc, entEnv0, rpath, compInfo)
306 :     in EE.mark(mkStamp, foldl h entEnv decs)
307 :     end
308 :     (*
309 :     * The following may be wrong, but since ASSERTION! the bound symbols
310 :     * are all distinct,it would not appear to cause any harm.
311 :     *)
312 :     | LOCALdec (localDec, bodyDec) =>
313 :     let val entEnv1 = evalDec(localDec, depth, epc,
314 :     entEnv, IP.empty, compInfo)
315 :     in evalDec(bodyDec, depth, epc, entEnv1, rpath, compInfo)
316 :     end
317 :    
318 :     | _ => entEnv)
319 :    
320 :     and evalStp (stpExp, depth, epc, entEnv,
321 :     compInfo as {mkStamp,...}: EU.compInfo) =
322 :     case stpExp
323 : blume 587 of (* CONST stamp => stamp
324 :     | *) NEW => mkStamp()
325 :     | GETSTAMP strExp => #stamp (#1 (evalStr(strExp, depth, epc, NONE,
326 :     entEnv, IP.empty, compInfo)))
327 : monnier 249
328 :     (*
329 :     val evalApp = Stats.doPhase(Stats.makePhase "Compiler 044 x-evalApp") evalApp
330 :     *)
331 :    
332 :     end (* toplevel local *)
333 :     end (* structure EvalEntity *)

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