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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 168 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories. *)
2 :     (* moduleutil.sml *)
3 :    
4 :     structure ModuleUtil : MODULEUTIL =
5 :     struct
6 :    
7 :     local structure S = Symbol
8 :     structure SP = SymPath
9 :     structure IP = InvPath
10 :     structure CVP = ConvertPaths
11 :     structure EP = EntPath
12 :     structure EPC = EntPathContext
13 :     structure A = Access
14 :     structure II = InlInfo
15 :     structure T = Types
16 :     structure TU = TypesUtil
17 :     structure V = VarCon
18 :     structure B = Bindings
19 :     structure EE = EntityEnv
20 :     structure ST = Stamps
21 :     structure M = Modules
22 :     structure MI = ModuleId
23 :     structure SE = StaticEnv
24 :     open Modules
25 :     in
26 :    
27 :     (* debugging hooks *)
28 :     val say = Control.Print.say
29 :     val debugging = Control.CG.mudebugging (* ref false *)
30 :     fun debugmsg (msg: string) =
31 :     if !debugging then (say msg; say "\n") else ()
32 :    
33 :     fun bug s = ErrorMsg.impossible ("ModuleUtil: " ^ s)
34 :    
35 :     (*
36 :     * Look up the entity corresponding to a given symbol in the `elements'
37 :     * of a signature and the corresponding `entities' from a structure
38 :     * realization. The (dynamic) access fields of structures and
39 :     * functors are adjusted before they are returned. The static accesses
40 :     * of types, structures, and functors are just returned.
41 :     *
42 :     * Used by the (structure and functor) matching functions.
43 :     *)
44 :    
45 :     exception Unbound of S.symbol
46 :    
47 :     fun getSpec (elements, sym) =
48 :     let fun h [] = (debugmsg("$getSpec "^S.name sym); raise (Unbound sym))
49 :     | h ((s, sp) :: elemr) = if S.eq(s, sym) then sp else h elemr
50 :     in h elements
51 :     end
52 :    
53 :     (*
54 :     * the following might be used to speedup the signature lookup process
55 :     *
56 :     * fun getSpec (elements, sym) =
57 :     * Env.look(elements,sym)
58 :     * handle Env.Unbound => raise (Unbound sym)
59 :     *
60 :     * we'll use more efficient represntations for elements in the future.
61 :     *)
62 :    
63 :     (*** return the entity variable of a particular spec ***)
64 :     fun getSpecVar (STRspec{entVar,...}) = SOME entVar
65 :     | getSpecVar (TYCspec{entVar,...}) = SOME entVar
66 :     | getSpecVar (FCTspec{entVar,...}) = SOME entVar
67 :     | getSpecVar _ = NONE
68 :    
69 :     (*** The function getTyc is used in modules/sigmatch.sml only ***)
70 :     fun getTyc (elements, entEnv, sym) =
71 :     case getSpec (elements, sym)
72 :     of TYCspec{entVar,...} => (EE.lookTycEnt(entEnv,entVar), entVar)
73 :     | _ => bug "getTyc: wrong spec"
74 :    
75 :     (*** The function getStr is used in modules/sigmatch.sml only ***)
76 :     fun getStr (elements, entEnv, sym, dacc, dinfo) =
77 :     case getSpec(elements, sym)
78 :     of STRspec{sign, slot, def, entVar} =>
79 :     (case EE.look(entEnv,entVar)
80 :     of STRent entity =>
81 :     (STR{sign = sign, rlzn = entity, access = A.selAcc(dacc,slot),
82 :     info = II.selInfo(dinfo, slot)}, entVar)
83 :     | _ => bug "getStr: bad entity")
84 :     | _ => bug "getStr: wrong spec"
85 :    
86 :     (*** The function getFct is used in modules/sigmatch.sml only ***)
87 :     fun getFct (elements, entEnv, sym, dacc, dinfo) =
88 :     case getSpec(elements, sym)
89 :     of FCTspec{sign, slot, entVar} =>
90 :     (case EE.look(entEnv,entVar)
91 :     of FCTent entity =>
92 :     (FCT{sign = sign, rlzn = entity, access = A.selAcc(dacc,slot),
93 :     info = II.selInfo(dinfo, slot)}, entVar)
94 :     | _ => bug "getFct: bad entity")
95 :     | _ => bug "getFct: wrong spec"
96 :    
97 :     val errorStrStamp = ST.special "ERRORstr"
98 :     val errorStrName = InvPath.IPATH[S.strSymbol "ERRORstr"]
99 :    
100 :     fun getStrStamp(STR{rlzn={stamp,...},...}) = stamp
101 :     | getStrStamp ERRORstr = errorStrStamp
102 :     | getStrStamp _ = bug "getStrStamp"
103 :    
104 :     fun getStrName(STR{rlzn={rpath,...},...}) = rpath
105 :     | getStrName ERRORstr = errorStrName
106 :     | getStrName _ = bug "getStrName"
107 :    
108 :     fun getStrs(STR{sign=SIG{elements,...},rlzn={entities,...}, access, info}) =
109 :     List.mapPartial
110 :     (fn (sym,STRspec{sign,slot,def,entVar}) =>
111 :     SOME(STR{sign = sign,
112 :     rlzn = EE.lookStrEnt(entities,entVar),
113 :     access = A.selAcc(access, slot),
114 :     info = II.selInfo(info, slot)})
115 :     | _ => NONE) elements
116 :     | getStrs ERRORstr = nil
117 :     | getStrs _ = bug "getStrs"
118 :    
119 :     fun getTycs(STR{sign=SIG{elements,...},rlzn={entities,...},...}) =
120 :     let val tycvars = List.mapPartial
121 :     (fn (sym,TYCspec{entVar,...}) => SOME entVar
122 :     | _ => NONE) elements
123 :     in List.map (fn tycVar => EE.lookTycEnt(entities,tycVar)) tycvars
124 :     end
125 :     | getTycs ERRORstr = nil
126 :     | getTycs _ = bug "getTycs"
127 :    
128 :     fun getSigSymbols(SIG{symbols,...}) = symbols
129 :     | getSigSymbols _ = nil
130 :    
131 :     fun getStrSymbols(STR{sign,...}) = getSigSymbols sign
132 :     | getStrSymbols _ = nil
133 :    
134 :     (*** Translate a tycon in a given entityEnv ***)
135 :     fun transTycon entEnv (T.PATHtyc{entPath,path,...}) =
136 :     (EE.lookTycEP(entEnv,entPath)
137 :     handle EE.Unbound =>
138 :     (debugmsg (String.concat["$transTycon ",
139 :     IP.toString path," ",
140 :     EP.entPathToString entPath]);
141 :     raise EE.Unbound))
142 :     | transTycon _ tycon = tycon
143 :    
144 :    
145 :     (*
146 :     * Translate a type in a given entityEnv
147 :     *
148 :     * We should never need to recurse inside each DEFtyc's body because
149 :     * a DEFtycs is either rigid or has been relativized as a whole into
150 :     * a PATHtyc with an entPath somewhere before.
151 :     *)
152 :     fun transType entEnv ty =
153 :     TU.mapTypeFull (transTycon entEnv) ty
154 :     handle EE.Unbound => (debugmsg "$transType"; raise EE.Unbound)
155 :    
156 : monnier 45 (*
157 :     val transTyconPhase = (Stats.makePhase "Compiler 033 4-transTycon")
158 : monnier 16 val transTycon =
159 : monnier 45 fn x => fn y => (Stats.doPhase transTyconPhase (transTycon x) y)
160 : monnier 16
161 : monnier 45 val transTypePhase = (Stats.makePhase "Compiler 033 5-transType")
162 : monnier 16 val transType =
163 : monnier 45 fn x => fn y => (Stats.doPhase transTypePhase (transType x) y)
164 :     *)
165 : monnier 16
166 :     fun strDefToStr(CONSTstrDef str, _) = str
167 :     | strDefToStr(VARstrDef(sign,entPath), entEnv) =
168 :     STR{sign=sign,rlzn=EE.lookStrEP(entEnv,entPath),
169 :     access=A.nullAcc, info=II.nullInfo}
170 :    
171 :     (*
172 :     * two pieces of essential structure information gathered during
173 :     * the environment lookup. SIGINFO is returned if the structure
174 :     * being searched is a STRSIG; otherwise it return STRINFO.
175 :     *)
176 :     datatype strInfo = SIGINFO of EP.entPath (* reverse order! *)
177 :     | STRINFO of strEntity * A.access * II.inl_info
178 :    
179 :     val bogusInfo = STRINFO (bogusStrEntity, A.nullAcc, II.nullInfo)
180 :    
181 :     fun getStrElem (sym, sign as SIG{elements,...}, sInfo) =
182 :     (case getSpec(elements,sym)
183 :     of STRspec{sign=subsig, slot, def, entVar} =>
184 :     (let val newInfo =
185 :     case sInfo
186 :     of SIGINFO ep => SIGINFO (entVar::ep)
187 :     | STRINFO (rlzn as {entities,...}, dacc, dinfo) =>
188 :     STRINFO(EE.lookStrEnt(entities,entVar),
189 :     A.selAcc(dacc,slot), II.selInfo(dinfo,slot))
190 :     in (subsig, newInfo)
191 :     end)
192 :     | _ => bug "getStrElem: wrong spec case")
193 :    
194 :     | getStrElem (sym, sign, _) = (sign, bogusInfo)
195 :    
196 :     fun getFctElem(sym, sign as SIG{elements,...},
197 :     sinfo as STRINFO(rlzn as {entities,...}, dacc, dinfo)) =
198 :     (case getSpec(elements, sym)
199 :     of FCTspec{sign=subfsig, entVar, slot} =>
200 :     FCT{sign=subfsig, rlzn=EE.lookFctEnt(entities,entVar),
201 :     access=A.selAcc(dacc, slot), info=II.selInfo(dinfo, slot)}
202 :     | _ => bug "mkFctVar - bad spec")
203 :    
204 :     | getFctElem _ = ERRORfct
205 :    
206 :     fun mkTyc(sym, sp, SIG{elements,...}, sInfo) =
207 :     (case getSpec (elements, sym)
208 : monnier 167 of TYCspec{spec,entVar=ev,repl,scope} =>
209 : monnier 16 (case sInfo
210 :     of SIGINFO ep =>
211 :     T.PATHtyc{arity=TU.tyconArity spec, entPath=rev(ev::ep),
212 :     path=CVP.invertSPath sp}
213 :     | STRINFO (rlzn as {entities,...}, _, _) =>
214 :     EE.lookTycEnt(entities, ev))
215 :    
216 :     | _ => bug "mkTyc: wrong spec case")
217 :    
218 :     | mkTyc _ = T.ERRORtyc
219 :    
220 :     fun mkVal(sym, sp, sign as SIG{elements,...},
221 :     sInfo as STRINFO({entities,...}, dacc, dinfo)) : V.value =
222 :     (case getSpec(elements, sym)
223 :     of VALspec{spec,slot} =>
224 :     V.VAL(V.VALvar{access = A.selAcc(dacc,slot),
225 :     info = II.selInfo(dinfo,slot), path = sp,
226 :     typ = ref(transType entities spec)})
227 :    
228 : monnier 106 | CONspec{spec=T.DATACON{name, const, typ, rep, sign, lazyp}, slot} =>
229 : monnier 16 let val newrep =
230 :     case (rep, slot)
231 :     of (A.EXN _, SOME i) => A.EXN (A.selAcc(dacc,i))
232 :     | _ => rep
233 :    
234 :     in V.CON(T.DATACON{rep=newrep, name=name,
235 :     typ=transType entities typ,
236 : monnier 106 const=const, sign=sign, lazyp=lazyp})
237 : monnier 16 end
238 :    
239 :     | _ => bug "mkVal: wrong spec")
240 :    
241 :     | mkVal _ = V.VAL(V.ERRORvar)
242 :    
243 :    
244 :     fun mkStrBase(sym, sign, sInfo) =
245 :     let val (newsig, newInfo) = getStrElem(sym, sign, sInfo)
246 :     in case newsig
247 :     of ERRORsig => ERRORstr
248 :     | _ =>
249 :     (case newInfo
250 :     of STRINFO(newrlzn, newacc, newinfo) =>
251 :     STR{sign=newsig, rlzn=newrlzn, access=newacc, info=newinfo}
252 :     | SIGINFO ep => STRSIG{sign=newsig, entPath=rev ep})
253 :     end
254 :    
255 :     fun mkStr(sym, _, sign, sInfo) = mkStrBase(sym, sign, sInfo)
256 :    
257 :     fun mkStrDef(sym, _, sign, sInfo) =
258 :     let val (newsig, newInfo) = getStrElem(sym, sign, sInfo)
259 :     in case newsig
260 :     of ERRORsig => CONSTstrDef ERRORstr
261 :     | _ =>
262 :     (case newInfo
263 :     of STRINFO (newrlzn, newacc, newinfo) =>
264 :     CONSTstrDef(STR{sign=newsig, rlzn=newrlzn,
265 :     access=newacc, info=newinfo})
266 :     | SIGINFO ep => VARstrDef(newsig, rev ep))
267 :     end
268 :    
269 :     fun mkFct(sym, sp, sign, sInfo) = getFctElem(sym, sign, sInfo)
270 :    
271 :     fun getPath makeIt (str, SP.SPATH spath, fullsp) =
272 :     let fun loop([sym], sign, sInfo) = makeIt(sym, fullsp, sign, sInfo)
273 :     | loop(sym::rest, sign, sInfo) =
274 :     let val (newsig, newsInfo) = getStrElem(sym, sign, sInfo)
275 :     in loop(rest, newsig, newsInfo)
276 :     end
277 :     | loop _ = bug "getPath.loop"
278 :    
279 :     in case str
280 :     of STR{sign, rlzn, access, info} =>
281 :     loop(spath, sign, STRINFO(rlzn, access, info))
282 :     | STRSIG{sign, entPath} =>
283 :     loop(spath, sign, SIGINFO (rev entPath))
284 :     | _ => loop(spath, ERRORsig, bogusInfo)
285 :     end
286 :    
287 :     val getTycPath : M.Structure * SP.path * SP.path -> T.tycon =
288 :     getPath mkTyc
289 :     val getValPath : M.Structure * SP.path * SP.path -> V.value =
290 :     getPath mkVal
291 :     val getStrPath : M.Structure * SP.path * SP.path -> M.Structure =
292 :     getPath mkStr
293 :     val getFctPath : M.Structure * SP.path * SP.path -> M.Functor =
294 :     getPath mkFct
295 :     val getStrDef : M.Structure * SP.path * SP.path -> M.strDef =
296 :     getPath mkStrDef
297 :    
298 :     fun checkPathSig(sign: M.Signature, spath: SP.path) : S.symbol option =
299 :     let val str = STRSIG{sign=sign,entPath=[]:EP.entPath}
300 :     fun checkLast(sym,_,SIG{elements,...},_) = (getSpec(elements,sym);())
301 :     | checkLast(sym,_,ERRORsig,_) = ()
302 :     in getPath checkLast (str,spath,SP.empty);
303 :     NONE
304 :     end
305 :     handle Unbound sym => SOME sym
306 :    
307 :     fun errBinding sym =
308 :     case S.nameSpace sym
309 :     of S.VALspace => B.VALbind V.ERRORvar
310 :     | S.TYCspace => B.TYCbind T.ERRORtyc
311 :     | S.STRspace => B.STRbind M.ERRORstr
312 :     | S.FCTspace => B.FCTbind M.ERRORfct
313 :     | _ => raise (Unbound sym)
314 :    
315 :     fun eqSign(SIG{stamp=s1,closed=true, ...},
316 :     SIG{stamp=s2,closed=true, ...}) = ST.eq(s1,s2)
317 :     | eqSign _ = false
318 :    
319 :     fun eqOrigin(STR{rlzn={stamp=s1,...},...},
320 :     STR{rlzn={stamp=s2,...},...}) = ST.eq(s1,s2)
321 :     | eqOrigin _ = false
322 :    
323 :    
324 :     (*
325 : monnier 93 * The following functions are used in CMStaticEnv and module elaboration
326 : monnier 16 * for building EntPathContexts. They extract module ids from modules.
327 :     *)
328 :     fun tycId(T.GENtyc{stamp,...}) = ModuleId.TYCid stamp
329 :     | tycId(T.DEFtyc{stamp,...}) = ModuleId.TYCid stamp
330 :     | tycId _ = bug "tycId"
331 :    
332 :     fun strId(STR{rlzn={stamp=rlznst,...},sign=SIG{stamp=sigst,...},...}) =
333 :     MI.STRid{rlzn=rlznst,sign=sigst}
334 :     | strId _ = bug "strId"
335 :    
336 :     fun strId2(SIG{stamp=sigst,...}, {stamp=rlznst,...} : strEntity) =
337 :     MI.STRid{rlzn=rlznst,sign=sigst}
338 :     | strId2 _ = bug "strId2"
339 :    
340 :     fun fsigId(FSIG{paramsig=SIG{stamp=sp,...},bodysig=SIG{stamp=sb,...},...}) =
341 :     MI.FSIGid{paramsig=sp,bodysig=sb}
342 :     | fsigId _ = bug "fsigId"
343 :    
344 :     fun fctId(FCT{rlzn={stamp,...},sign, ...}) =
345 :     MI.FCTid{rlzn=stamp,sign=fsigId sign}
346 :     | fctId _ = bug "fctId"
347 :    
348 :     fun fctId2(sign, {stamp,...} : fctEntity) =
349 :     MI.FCTid{rlzn=stamp,sign=fsigId sign}
350 :    
351 :     (*
352 :     * The reason that relativizeType does not need to get inside
353 :     * DEFtyc is because of our assumptions that the body in DEFtyc
354 :     * has already been relativized, when DEFtyc is elaborated;
355 :     * otherwise, this DEFtyc must be a rigid tycon.
356 :     *)
357 :     fun relativizeTyc epContext : T.tycon -> T.tycon * bool =
358 :     let fun mapTyc(tyc as (T.GENtyc{stamp,...} | T.DEFtyc{stamp,...})) =
359 :     let val tyc_id = ModuleId.TYCid stamp
360 :     in debugmsg ("mapTyc: "^ModuleId.idToString tyc_id);
361 :     case EPC.lookPath(epContext,tyc_id)
362 :     of NONE => (debugmsg "tyc not mapped 1"; (tyc,false))
363 :     | SOME entPath =>
364 :     let val tyc' = T.PATHtyc{arity=TU.tyconArity tyc,
365 :     entPath=entPath,
366 :     path=TU.tycPath tyc}
367 :     in debugmsg("tyc mapped: "^
368 :     Symbol.name(TypesUtil.tycName tyc'));
369 :     (tyc',true)
370 :     end
371 :     end
372 :     | mapTyc(tyc as T.PATHtyc _) =
373 :     (* assume this is a local tycon within the current signature *)
374 :     (debugmsg "tyc not mapped 2";
375 :     (tyc,true))
376 :     | mapTyc tyc = (debugmsg "tyc not mapped 3"; (tyc,false))
377 :    
378 :     fun mapTyc' tyc =
379 :     (debugmsg("mapTyc': "^(Symbol.name(TypesUtil.tycName tyc)));
380 :     mapTyc tyc)
381 :     in mapTyc'
382 :     end
383 :    
384 :     fun relativizeType epContext ty : T.ty * bool =
385 :     let val relative = ref false
386 :     fun vizTyc tyc =
387 :     let val (tyc',rel) = relativizeTyc epContext tyc
388 :     in relative := (!relative orelse rel);
389 :     tyc'
390 :     end
391 :     in (TU.mapTypeFull vizTyc ty, !relative)
392 :     end
393 :    
394 :    
395 :     (*
396 : monnier 45 val relativizeTypePhase = (Stats.makePhase "Compiler 033 2-vizType")
397 : monnier 16 val relativizeType =
398 :     fn x => fn y =>
399 : monnier 45 (Stats.doPhase relativizeTypePhase (relativizeType x) y)
400 : monnier 16
401 :     *)
402 :    
403 :     (*
404 :     * getBinding(sym,str): return binding for element sym of structure str
405 :     * - used only inside the function openStructure
406 :     * - raises ModuleUtil.Unbound if sym not found in sig
407 :     *)
408 :     fun getBinding (sym, str as STR{sign as SIG{elements,...},
409 :     rlzn as {entities,...},
410 :     access=dacc, info=dinfo}) =
411 :     let val sinfo = STRINFO(rlzn, dacc, dinfo)
412 :     in case S.nameSpace sym
413 :     of S.VALspace =>
414 :     (case mkVal(sym, SP.SPATH[sym], sign, sinfo)
415 :     of V.VAL v => B.VALbind v
416 :     | V.CON d => B.CONbind d)
417 :    
418 :     | S.TYCspace => B.TYCbind(mkTyc(sym, SP.SPATH[sym], sign, sinfo))
419 :     | S.STRspace => B.STRbind(mkStrBase(sym, sign, sinfo))
420 :     | S.FCTspace => B.FCTbind(getFctElem(sym, sign, sinfo))
421 :     | sp => (debugmsg ("getBinding: "^S.symbolToString sym);
422 :     raise (Unbound sym))
423 :     end
424 :    
425 :     | getBinding (sym, STRSIG{sign as SIG{elements, ...},entPath=ep}) =
426 :     let val sinfo = SIGINFO(rev ep)
427 :     in case S.nameSpace sym
428 :     of S.TYCspace => B.TYCbind(mkTyc(sym, SP.SPATH[sym], sign, sinfo))
429 :     | S.STRspace => B.STRbind(mkStrBase(sym, sign, sinfo))
430 :     | _ => (debugmsg ("getBinding: "^S.symbolToString sym);
431 :     raise (Unbound sym))
432 :     end
433 :    
434 :     | getBinding (sym, STR{sign=ERRORsig,...}) = errBinding sym
435 :     | getBinding (sym, ERRORstr) = errBinding sym
436 :     | getBinding _ = bug "getBinding - bad arg"
437 :    
438 :     fun openStructure(env: SE.staticEnv, str) =
439 :     let fun look sym = getBinding(sym,str) handle Unbound _ => raise SE.Unbound
440 :     val symbols = getStrSymbols str
441 :     val genSyms = (fn () => symbols)
442 :     val nenv = SE.special(look, genSyms)
443 :     in SE.atop(nenv,env)
444 :     end
445 :    
446 :     (** extract inl_info from a list of bindings *)
447 :     fun extractInfo(B.STRbind(M.STR{info, ...})) = info
448 :     | extractInfo(B.FCTbind(M.FCT{info, ...})) = info
449 :     | extractInfo(B.VALbind(V.VALvar{info, ...})) = info
450 :     | extractInfo(B.CONbind _) = II.nullInfo
451 :     | extractInfo(B.STRbind _) = II.nullInfo
452 :     | extractInfo(B.FCTbind _) = II.nullInfo
453 :     | extractInfo _ = bug "unexpected binding in extractInfo"
454 :    
455 :     (* extract all signature names from a structure --
456 :     * doesn't look into functor components *)
457 :     fun getSignatureNames(STR{sign,...} | STRSIG{sign,...}) =
458 :     let fun sigNames(SIG{name,elements,...},names) =
459 :     foldl (fn ((_,STRspec{sign,...}),ns) =>
460 :     sigNames(sign, ns)
461 :     | (_,ns) => ns)
462 :     (case name of SOME n => n::names | NONE => names)
463 :     elements
464 :     | sigNames(ERRORsig,names) = names
465 :     fun removeDups (x::(rest as y::_),z) =
466 :     if S.eq(x,y) then removeDups(rest,z) else removeDups(rest,x::z)
467 :     | removeDups (x::nil,z) = x::z
468 :     | removeDups (nil,z) = z
469 :     in removeDups(Sort.sort S.symbolGt(sigNames(sign,nil)), nil)
470 :     end
471 :     | getSignatureNames(ERRORstr) = nil
472 :    
473 :     end (* local *)
474 :     end (* structure ModuleUtil *)
475 :    
476 :     (*
477 : monnier 167 * $Log: moduleutil.sml,v $
478 :     * Revision 1.3 1998/05/23 14:10:10 george
479 :     * Fixed RCS keyword syntax
480 :     *
481 : monnier 16 *)

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