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

Annotation of /sml/branches/primop-branch-3/compiler/Elaborator/modules/evalent.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3379 - (view) (download)

1 : blume 902 (* 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 : gkuan 3046 * EntPathContext.context
9 : blume 902 * InvPath.path * ElabUtil.compInfo
10 :     -> Modules.strEntity
11 :    
12 :     val debugging : bool ref
13 :    
14 :     end (* signature EVALENTITY *)
15 :    
16 : gkuan 2740 structure EvalEntity : EVALENTITY =
17 : blume 902 struct
18 :    
19 : dbm 3299 local
20 : blume 902 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 MI = ModuleId
28 :     structure MU = ModuleUtil
29 :     open Modules
30 : dbm 3285 in
31 : blume 902
32 :     (* debugging *)
33 :     val say = Control_Print.say
34 : gkuan 3345 val debugging = (* ElabDataControl.eedebugging *) ref true
35 : blume 902 fun debugmsg (msg: string) =
36 :     if !debugging then (say msg; say "\n") else ()
37 :    
38 :     open ElabDebug
39 :    
40 :     val debugPrint = (fn x => debugPrint debugging x) (* Value Restriction *)
41 :     fun bug msg = ErrorMsg.impossible ("EvalEntity: " ^ msg);
42 :    
43 : dbm 3291 (* special symbols -- defined in SpecialSymbols *)
44 : dbm 3286 val resultId = SpecialSymbols.resultId
45 :     val returnId = SpecialSymbols.returnId
46 :     val anonFctSym = SpecialSymbols.anonFctSym
47 :     val paramSym = SpecialSymbols.paramSym
48 :    
49 : blume 902 val defaultError =
50 :     ErrorMsg.errorNoFile(ErrorMsg.defaultConsumer(),ref false) (0,0)
51 :    
52 : dbm 3285 (* local "conditional" variant of EntPathContext.enterOpen *)
53 :     fun enterOpen(epc: EPC.context, NONE: EntPath.entVar option) = epc
54 :     | enterOpen(epc, SOME entv) = EPC.enterOpen(epc,entv)
55 :    
56 : blume 902 fun evalTyc (entv, tycExp, entEnv, epc, rpath,
57 : dbm 3287 compInfo as {mkStamp,...}: EU.compInfo) : T.tycon =
58 : blume 902 case tycExp
59 :     of CONSTtyc tycon => tycon
60 :     | FORMtyc (T.GENtyc { kind, arity, eq, path, ... }) =>
61 :     (case kind of
62 :     T.DATATYPE{index=0, stamps, freetycs, family, root=NONE} =>
63 :     let val viztyc = MU.transTycon entEnv
64 :     val nstamps = Vector.map (fn _ => mkStamp()) stamps
65 :     val nst = Vector.sub(nstamps,0)
66 :     val nfreetycs = map viztyc freetycs
67 : dbm 3045 val _ = EPC.bindTycEntVar (epc, nst, entv)
68 : blume 902 in
69 :     T.GENtyc{stamp=nst, arity=arity, eq=eq,
70 :     kind=T.DATATYPE{index=0, stamps=nstamps,
71 :     root=NONE,
72 :     freetycs=nfreetycs,
73 :     family=family},
74 :     path=IP.append(rpath,path), stub=NONE}
75 :     end
76 :     | T.DATATYPE{index=i, root=SOME rtev, ...} =>
77 :     let val (nstamps, nfreetycs, nfamily) =
78 :     case EE.lookTycEnt(entEnv, rtev)
79 :     of T.GENtyc { kind = T.DATATYPE dt, ... } =>
80 :     (#stamps dt, #freetycs dt, #family dt)
81 :     | _ => bug "unexpected case in evalTyc-FMGENtyc (2)"
82 :     val nst = Vector.sub(nstamps,i)
83 : dbm 3045 val _ = EPC.bindTycEntVar (epc, nst, entv)
84 : blume 902 in
85 :     T.GENtyc{stamp=nst, arity=arity,
86 :     kind=T.DATATYPE{index=i, stamps=nstamps,
87 :     root=NONE,
88 :     freetycs=nfreetycs,
89 :     family=nfamily},
90 :     path=IP.append(rpath,path),
91 :     eq=eq, stub=NONE}
92 :     end
93 :     | _ => bug "unexpected GENtyc in evalTyc")
94 :     | FORMtyc (T.DEFtyc{stamp,tyfun=T.TYFUN{arity, body},strict,path}) =>
95 :     let val nst = mkStamp()
96 :     (* tycId=stamp (this should perhaps be more abstract some day) *)
97 : dbm 3045 val _ = EPC.bindTycEntVar (epc, nst, entv)
98 : dbm 3287 in T.DEFtyc{stamp=nst,
99 : blume 902 tyfun=T.TYFUN{arity=arity,
100 :     body=MU.transType entEnv body},
101 :     strict=strict, path=IP.append(rpath,path)}
102 :     end
103 :     | VARtyc entPath =>
104 :     (debugmsg (">>evalTyc[VARtyc]: "^EP.entPathToString entPath);
105 :     EE.lookTycEP(entEnv,entPath))
106 :     | _ => bug "unexpected tycExp in evalTyc"
107 :    
108 : dbm 3285 and evalStr(strExp, epc, entsvOp, entEnv, rpath,
109 : dbm 3287 compInfo as {mkStamp,...}: EU.compInfo)
110 : gkuan 3289 : strEntity * entityEnv =
111 : blume 902 (debugmsg ("[Inside EvalStr ......");
112 :     case strExp
113 :     of VARstr entPath =>
114 :     (debugmsg (">>evalStr[VARstr]: "^EP.entPathToString entPath);
115 :     (EE.lookStrEP(entEnv,entPath), entEnv))
116 :    
117 : gkuan 3345 | CONSTstr strEnt => (debugmsg ("--evalStr[CONSTstr]"); (strEnt, entEnv))
118 : blume 902
119 :     | STRUCTURE {stamp, entDec} =>
120 : gkuan 3345 let val _ = debugmsg "--evalStr[STRUCTURE]"
121 :     val epc = enterOpen(epc, entsvOp)
122 : dbm 3287 val stp = evalStamp(stamp, epc, entEnv, compInfo)
123 :     val env = evalDec(entDec, epc, entEnv, rpath, compInfo)
124 : blume 902 in
125 :     ({stamp = stp, entities=env,
126 : dbm 3287 rpath = rpath, stub = NONE,
127 :     properties = PropList.newHolder ()},
128 : blume 902 entEnv)
129 :     end
130 :    
131 :     | APPLY (fctExp, strExp) =>
132 : gkuan 3345 let val _ = debugmsg "--evalStr[APPLY]"
133 :     val (fctRlzn, entEnv1) =
134 : dbm 3287 evalFct(fctExp, epc, entEnv, compInfo)
135 : blume 902 val (argRlzn, entEnv2) =
136 : dbm 3287 evalStr(strExp, epc, entsvOp, entEnv1,
137 :     IP.empty, compInfo)
138 : gkuan 3345 (* [GK Debug Printout] *)
139 :     val _ = debugPrint ("--evalStr[APPLY]:fctRlzn=",
140 :     fn ppstrm => fn rlzn =>
141 :     PPModules.ppEntity ppstrm (rlzn,StaticEnv.empty,100),
142 :     FCTent fctRlzn)
143 :     val _ = debugPrint ("--evalStr[APPLY]:argRlzn=",
144 :     fn ppstrm => fn rlzn =>
145 :     PPModules.ppEntity ppstrm (rlzn,StaticEnv.empty,100),
146 :     STRent argRlzn)
147 : dbm 3285 val epc = enterOpen(epc, entsvOp)
148 : gkuan 3046 in (evalApp(fctRlzn, argRlzn, epc, rpath, compInfo),
149 : blume 902 entEnv2)
150 :     end
151 :    
152 :     | LETstr (entDec, strExp) =>
153 : dbm 3287 let val entEnv1 = evalDec(entDec, epc,
154 : blume 902 entEnv, rpath, compInfo)
155 :     val (strEnt, entEnv2) =
156 : dbm 3287 evalStr(strExp, epc, entsvOp, entEnv1,
157 :     rpath, compInfo)
158 : blume 902
159 :     in (strEnt, entEnv2)
160 :     end
161 :    
162 :     | ABSstr (sign, strExp) =>
163 : gkuan 3345 let val _ = debugmsg "--evalStr[ABSstr]"
164 :     val (srcRlzn, entEnv1) =
165 : dbm 3287 evalStr(strExp, epc, entsvOp, entEnv, rpath, compInfo)
166 : dbm 3350 val flex = let val base = mkStamp()
167 :     in (fn s => (case Stamps.compare(base,s)
168 :     of LESS => true
169 :     | _ => false))
170 :     end
171 :     val {rlzn, ...} =
172 : gkuan 3348 Instantiate.instAbstr{sign=sign, entEnv=entEnv,
173 :     srcRlzn=srcRlzn,
174 : dbm 3291 rpath=rpath, region=S.nullRegion,
175 :     compInfo=compInfo}
176 : dbm 3350 (* because the abstraction instantiation creates new tyc stamps,
177 :     we have to bind them in the pathmap of the epcontext.
178 : dbm 3338 But not all new stamps are represented in abstycs, only
179 :     FORMALs (primaries)!
180 : blume 902 *)
181 : dbm 3285 val epc = enterOpen(epc, entsvOp)
182 : dbm 3350 in MU.mapPaths(epc, sign, rlzn, flex);
183 :     (rlzn, entEnv1)
184 : blume 902 end
185 :    
186 :     | CONSTRAINstr {boundvar,raw,coercion} =>
187 :     (* propagage the context rpath into the raw uncoerced structure *)
188 :     let val (rawEnt, entEnv1) =
189 : dbm 3287 evalStr(raw, epc, SOME boundvar,
190 :     entEnv, rpath, compInfo)
191 : blume 902 val entEnv2 = EE.bind(boundvar, STRent rawEnt, entEnv1)
192 :     val (strEnt, entEnv3) =
193 : dbm 3287 evalStr(coercion, epc, entsvOp,
194 :     entEnv2, IP.empty, compInfo)
195 : blume 902
196 :     in (strEnt, entEnv3)
197 :     end
198 :    
199 :     | FORMstr _ => bug "unexpected FORMstr in evalStr")
200 :    
201 :    
202 : dbm 3350 and evalFct (fctExp, epc, entEnv,
203 : blume 902 compInfo as {mkStamp,...}: EU.compInfo) =
204 : gkuan 3345 (debugmsg "--evalFct";
205 : blume 902 case fctExp
206 :     of VARfct entPath =>
207 :     (debugmsg (">>evalFct[VARfct]: "^EP.entPathToString entPath);
208 :     (EE.lookFctEP(entEnv,entPath), entEnv))
209 :    
210 :     | CONSTfct fctEntity => (fctEntity, entEnv)
211 :    
212 : gkuan 3378 | LAMBDA{param, body} =>
213 : gkuan 3379 (debugmsg "--evalFct[LAMBDA]";
214 :     ({stamp = mkStamp (),
215 : gkuan 3345 exp=fctExp,
216 :     closureEnv=entEnv,
217 : gkuan 3379 primaries=[],
218 :     paramEnv=ERReenv, (* [FIXME] primaries and paramEnv must be set *)
219 : blume 902 rpath=IP.IPATH[anonFctSym],
220 : dbm 3287 stub=NONE,
221 :     properties = PropList.newHolder ()},
222 : gkuan 3379 entEnv))
223 : blume 902
224 :     | LETfct (entDec, fctExp) =>
225 : gkuan 3046 let val entEnv1 = evalDec(entDec, epc,
226 : blume 902 entEnv, IP.empty, compInfo)
227 :     val (fctEnt, entEnv2) =
228 : dbm 3350 evalFct(fctExp, epc, entEnv1, compInfo)
229 : blume 902 in (fctEnt, entEnv2)
230 : gkuan 3345 end)
231 : blume 902
232 : gkuan 3046 and evalApp(fctRlzn : Modules.fctEntity, argRlzn, epc, rpath,
233 : blume 902 compInfo as {mkStamp, ...} : EU.compInfo) =
234 : gkuan 3345 let val {closureEnv=env,exp=LAMBDA{param, body, ...}, ...} = fctRlzn
235 : blume 902 val nenv = EE.mark(mkStamp, EE.bind(param, STRent argRlzn, env))
236 :     val _ = debugmsg ("[Inside EvalAPP] ......")
237 : gkuan 2961 in case body
238 :     of (FORMstr(FSIG{paramsig, bodysig, ...})) =>
239 : dbm 3291 let (** failing to add the stamps into the epcontext is
240 : blume 902 a potential bug here. Will fix this in the
241 : dbm 3291 future. ZHONG. -- ??? doesn't bindEp below
242 :     do this? DBM **)
243 : gkuan 3345 val _ = debugmsg "--evalApp[FORMstr]"
244 : dbm 3350 val flex = let val base = mkStamp()
245 :     in (fn s => (case Stamps.compare(base,s)
246 :     of LESS => true
247 :     | _ => false))
248 :     end
249 :     val {rlzn, ...} =
250 : dbm 3291 Instantiate.instFormal {sign=bodysig, entEnv=nenv,
251 :     rpath=rpath, region=S.nullRegion,
252 :     compInfo=compInfo}
253 : dbm 3350 in MU.mapPaths(epc, bodysig, rlzn, flex);
254 :     rlzn
255 : blume 902 end
256 :     | _ =>
257 : gkuan 3345 let val _ = debugmsg "--evalApp[_]"
258 :     val (strEnt, deltaEE) =
259 : dbm 3291 evalStr(body, epc, NONE, nenv, rpath, compInfo)
260 :     (* invariant: deltaEE should always be same as nenv
261 :     if the body of an functor is always a BaseStr. Notice
262 :     functor body is constructed either in the source
263 :     programs (ml.grm) or in the elabmod.sml when dealing
264 :     with curried functor applications.
265 :     *)
266 : blume 902 in strEnt
267 :     end
268 :     end
269 :    
270 : dbm 3287 and evalDec(dec, epc, entEnv, rpath,
271 : gkuan 3289 compInfo as {mkStamp,...}: EU.compInfo): entityEnv =
272 : blume 902 (debugmsg ("[Inside EvalDec ......");
273 :     case dec
274 :     of TYCdec (entVar, tycExp) =>
275 :     let val tycEnt =
276 : dbm 3287 evalTyc(entVar, tycExp, entEnv, epc, rpath, compInfo)
277 : blume 902 in EE.bind(entVar, TYCent tycEnt, entEnv)
278 :     end
279 : dbm 3287
280 : blume 902 | STRdec (entVar, strExp, sym) =>
281 :     let val rpath' =
282 : dbm 3287 (* don't include returnId or resultId in rpaths *)
283 : blume 902 if Symbol.eq(sym, returnId)
284 :     orelse Symbol.eq(sym, resultId)
285 :     then rpath
286 :     else IP.extend(rpath,sym)
287 :     val (strEnt, entEnv1) =
288 : dbm 3287 evalStr(strExp, epc, SOME entVar,
289 :     entEnv, rpath', compInfo)
290 : blume 902 in EE.bind(entVar, STRent strEnt, entEnv1)
291 :     end
292 :    
293 :     | FCTdec (entVar, fctExp) =>
294 : gkuan 3345 let val _ = debugmsg "--evalDec[FCTdec]"
295 :     val (fctEnt, entEnv1) =
296 : dbm 3287 evalFct(fctExp, epc, entEnv, compInfo)
297 : blume 902 in EE.bind(entVar, FCTent fctEnt, entEnv1)
298 :     end
299 : dbm 3287
300 : blume 902 | SEQdec decs =>
301 :     let fun h (dec, entEnv0) =
302 : dbm 3287 evalDec(dec, epc, entEnv0, rpath, compInfo)
303 : blume 902 in EE.mark(mkStamp, foldl h entEnv decs)
304 :     end
305 :     (*
306 :     * The following may be wrong, but since ASSERTION! the bound symbols
307 :     * are all distinct,it would not appear to cause any harm.
308 :     *)
309 :     | LOCALdec (localDec, bodyDec) =>
310 : gkuan 3046 let val entEnv1 = evalDec(localDec, epc,
311 : blume 902 entEnv, IP.empty, compInfo)
312 : gkuan 3046 in evalDec(bodyDec, epc, entEnv1, rpath, compInfo)
313 : blume 902 end
314 :    
315 :     | _ => entEnv)
316 :    
317 : dbm 3287 (* evalStamp: evaluate a stamp expression. *)
318 :     and evalStamp (stpExp, epc, entEnv,
319 :     compInfo as {mkStamp,...}: EU.compInfo): Stamps.stamp =
320 : blume 902 case stpExp
321 : dbm 3287 of NEW => mkStamp() (* generate a fresh stamp *)
322 : gkuan 3046 | GETSTAMP strExp => #stamp (#1 (evalStr(strExp, epc, NONE,
323 : blume 902 entEnv, IP.empty, compInfo)))
324 : dbm 3287 (* evaluate a structure expression, then extract the stamp of the
325 :     * structure, throwing away the structure and the environment returned
326 :     * when it was evaluated *)
327 : blume 902 (*
328 :     val evalApp = Stats.doPhase(Stats.makePhase "Compiler 044 x-evalApp") evalApp
329 :     *)
330 :    
331 :     end (* toplevel local *)
332 :     end (* structure EvalEntity *)

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