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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3344 - (view) (download)

1 : blume 902 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* instantiate.sml *)
3 :    
4 :     (*
5 :     * This function constructs a dummy structure which satisfies all sharing
6 :     * constraints (explicit or induced) of a given signature. The resulting
7 :     * structure is used as the dummy parameter of a functor while elaborating
8 :     * and abstracting the functor body.
9 :     *
10 :     * The process of constructing the structure is essentially a unification
11 :     * problem. The algorithm used here is based on the Linear Unification
12 :     * algorithm first presented in [1] which was subsequently corrected
13 :     * and cleaned up in [2].
14 :     *
15 :     * The basic algorithm makes 2 passes. The first pass builds a DAG in
16 :     * a quasi-top down fashion which corresponds to the minimal structure
17 :     * needed to match the signature. The second pass takes the DAG and
18 :     * constructs the actualy dummy structure in a bottom-up fashion.
19 :     * Pass 1 has a fairly complicated control structure. The major
20 :     * invariant is that no node in the graph is expanded unless all
21 :     * of its ancestors have been expanded. This insures that all sharing
22 :     * constraints (explicit or derived) have reached the node at the
23 :     * time of its expansion. The second major invariant is that no
24 :     * node is finalized until all members in its equivalence class have
25 :     * been found.
26 :     *
27 :     * [1] Paterson, M.S., and Wegman, M.N., "Linear Unification",
28 :     * J. Comp. Sys. Sci. 16,2 (April 1978), pp. 158-167.
29 :     *
30 :     * [2] de Champeaux, D., "About the Paterson-Wegman Linear Unification
31 :     * Algorithm", J. of Comp. Sys. Sci. 32, 1986, pp. 79-88.
32 :     *)
33 :    
34 :     signature INSTANTIATE =
35 :     sig
36 :    
37 : dbm 3291 (*** instantiation of the formal functor parameter and body signatures ***)
38 :     val instFormal :
39 : blume 902 {sign : Modules.Signature,
40 :     entEnv : Modules.entityEnv,
41 :     rpath : InvPath.path,
42 :     region : SourceMap.region,
43 : dbm 3291 compInfo : ElabUtil.compInfo}
44 :     -> {rlzn: Modules.strEntity,
45 :     abstycs: Types.tycon list,
46 :     tyceps: EntPath.entPath list}
47 : blume 902
48 :     (*** instantiation of the structure abstractions ***)
49 :     val instAbstr :
50 :     {sign : Modules.Signature,
51 :     entEnv : Modules.entityEnv,
52 : dbm 3304 srcRlzn : Modules.strEntity, (* rlzn of structure being abstracted *)
53 :     rpath : InvPath.path,
54 : blume 902 region : SourceMap.region,
55 : dbm 3291 compInfo : ElabUtil.compInfo}
56 :     -> {rlzn: Modules.strEntity,
57 :     abstycs: Types.tycon list,
58 :     tyceps: EntPath.entPath list}
59 : blume 902
60 :     val debugging : bool ref
61 :    
62 :     end (* signature INSTANTIATE *)
63 :    
64 : gkuan 2740 structure Instantiate : INSTANTIATE =
65 : blume 902 struct
66 :    
67 :     local structure A = Access
68 :     structure ED = ElabDebug
69 :     structure EE = EntityEnv
70 :     structure EM = ErrorMsg
71 :     structure EP = EntPath
72 :     structure EU = ElabUtil
73 :     structure IP = InvPath
74 :     structure M = Modules
75 :     structure MU = ModuleUtil
76 :     structure PU = PrintUtil
77 :     structure S = Symbol
78 :     structure SP = SymPath
79 :     structure ST = Stamps
80 :     structure T = Types
81 :     structure TU = TypesUtil
82 :     open Modules Types
83 :     in
84 :    
85 :     (* ----------------------- utility functions ----------------------------- *)
86 :    
87 :     (* debugging *)
88 :     val say = Control_Print.say
89 :     val debugging = ElabControl.insdebugging (* ref false *)
90 :     fun debugmsg (msg: string) = if !debugging then (say msg; say "\n") else ()
91 :     fun bug s = EM.impossible ("Instantiate: " ^ s)
92 :    
93 :     fun wrap fname f arg =
94 :     if !debugging then
95 :     let val _ = say (">> "^fname^"\n")
96 :     val result = f arg
97 :     in say ("<< "^fname^"\n");
98 :     result
99 :     end
100 :     else f arg
101 :    
102 :     fun debugType(msg: string, tyc: T.tycon) =
103 :     ED.withInternals(fn () =>
104 :     ED.debugPrint debugging
105 :     (msg, PPType.ppTycon StaticEnv.empty, tyc))
106 :    
107 :    
108 :     (* error state *)
109 :     val error_found = ref false
110 :    
111 :     val infinity = 1000000 (* a big integer *)
112 :    
113 :     fun push(r,x) = (r := x::(!r))
114 :    
115 :     fun pathName (path: IP.path) : string =
116 :     SP.toString(ConvertPaths.invertIPath path)
117 :    
118 :     val eqOrigin = MU.eqOrigin
119 :     val eqSig = MU.eqSign
120 :    
121 :     fun sameStructure (STR { sign = sg1, rlzn = { stamp = s1, ... }, ... },
122 :     STR { sign = sg2, rlzn = { stamp = s2, ... }, ... }) =
123 :     eqSig (sg1, sg2) andalso ST.eq (s1, s2)
124 :     | sameStructure _ = false
125 :    
126 :     fun signName (SIG { name, ... }) = getOpt (Option.map S.name name, "Anonymous")
127 :     | signName ERRORsig = "ERRORsig"
128 :    
129 :    
130 :     (* -------------------- important data structures ------------------------ *)
131 :    
132 :     (*
133 :     * the different kinds of instantiations
134 :     *)
135 :     datatype instKind
136 : dbm 3291 = INST_ABSTR of M.strEntity (* a sealed signature ascription *)
137 :     | INST_FORMAL (* instantiating a functor param sig or formal functor result sig *)
138 : blume 902
139 :     (* datatype stampInfo
140 :     * encodes an instruction about how to get a stamp for a new entity
141 :     *)
142 :     datatype stampInfo
143 :     = STAMP of ST.stamp (* here is the stamp *)
144 :     | PATH of EP.entPath (* get the stamp of the entity designated by the path *)
145 :     | GENERATE (* generate a new stamp (using the mkStamp parameter) *)
146 :    
147 :     (* datatype entityInfo
148 :     * The contents of the finalEnt field of the FinalStr inst variant.
149 :     * Defined in finalize (in buildStrClass), used in instToStr to
150 :     * determine how to find or build the realization entity.
151 :     *
152 :     * The bool argument of GENERATE_ENT is normally true when there was
153 :     * a VARstrDef applying to the structure spec with a different signature
154 :     * than the spec. This means that the spec signature should be considered
155 :     * as open, despite what it's "closed" field might say. This was introduced
156 :     * to fix bug 1238. [dbm, 8/13/97]
157 :     *)
158 :     datatype entityInfo
159 :     = CONST_ENT of M.strEntity (* here it is *)
160 :     | PATH_ENT of EP.entPath (* find it via this entityPath *)
161 :     | GENERATE_ENT of bool (* generate a new one *)
162 :    
163 :     datatype tycInst
164 :     = INST of tycon (* already instantiated *)
165 :     | NOTINST of tycon (* needing instantiation *)
166 :    
167 :     (*
168 :     * This datatype represents the continually changing DAG that is being
169 :     * constructed by instantiate. We start off with just an Initial node.
170 :     * It is expanded into a Partial node whose children are
171 : dbm 2737 * initialized to Initial nodes. When all of the members of the node's
172 : blume 902 * equivalence class have been found, and converted to Partial nodes,
173 :     * the node is converted to FinalStr. Finally, we recurse on the children
174 :     * of the node.
175 :     *
176 :     * Invariants:
177 :     *
178 :     * The parent node is in a singleton equivalence class.
179 :     *
180 :     * All nodes that are about to be explored are either Initial or Partial.
181 :     * (Exploring a Final node implies circularity.)
182 :     *
183 :     * If a Final node's expanded field is true, then all of its children
184 :     * are Final with expanded field true.
185 :     *)
186 :     datatype inst
187 :     (* structure instances *)
188 :     = FinalStr of (* the equivalence class of this node is fully explored *)
189 :     {sign : M.Signature,
190 :     stamp : stampInfo ref,
191 :     slotEnv : slotEnv,
192 :     finalEnt: entityInfo ref,
193 :     expanded : bool ref}
194 :     | PartialStr of (* we are in the process of exploring the equiv. class *)
195 :     {sign : M.Signature,
196 :     path : IP.path,
197 :     slotEnv : slotEnv,
198 :     comps : (S.symbol * slot) list, (* sorted by symbol *)
199 :     depth : int,
200 :     final_rep : inst option ref}
201 :     | InitialStr of (* haven't started exploring the equiv. class *)
202 :     {sign : M.Signature,
203 :     sigDepth : int,
204 :     path : IP.path,
205 :     epath : EP.entPath,
206 :     slotEnv : slotEnv,
207 :     inherited : constraint list ref}
208 :     | NullStr
209 :     | ErrorStr
210 :    
211 :     (* tycon instances *)
212 :     | FinalTyc of tycInst ref
213 :     | PartialTyc of
214 :     {tycon : tycon,
215 :     path : IP.path,
216 :     epath: EP.entPath}
217 :     | InitialTyc of
218 :     {tycon : tycon,
219 :     path : IP.path,
220 :     epath: EP.entPath,
221 :     inherited : constraint list ref}
222 :     | NullTyc
223 :     | ErrorTyc
224 :    
225 :     (* functor instances *)
226 :     | FinalFct of
227 :     {sign : M.fctSig,
228 :     def : M.Functor option ref,
229 :     path: IP.path,
230 :     epath: EP.entPath}
231 :     | NullFct
232 :    
233 :     (*
234 :     * A constraint is essentially a directed arc indicating that two
235 :     * nodes are to be identified. The constraint is always interpreted
236 :     * relative to a structure inst node. The my_path field is a symbolic
237 :     * path (in regular order) indicating which subcomponent of the local
238 :     * inst is participating in the sharing. The other component is accessed
239 :     * by first finding the inst node in the its_ancestor slot, and then following
240 :     * the symbolic path its_path to the node. By going through the
241 :     * ancestor, we are able to insure that the ancestor is explored
242 :     * before the actual component is, so that its inherited constraints are
243 :     * propagated downward properly.
244 :     *)
245 :     and constraint
246 :     = SHARE of {my_path : SP.path, (* regular symbolic path *)
247 :     its_ancestor : slot,
248 :     its_path : SP.path, (* regular symbolic path *)
249 :     depth : int} (* signature nesting depth of base constraint *)
250 :     | SDEFINE of strDef * int (* int is signature nesting depth of defn *)
251 :     | TDEFINE of tycInst * int (* int is signature nesting depth of defn *)
252 :    
253 :     (* slot: a node in the graph (maybe "node" would be a better name?) *)
254 :     withtype slot = inst ref
255 :    
256 :     (* slotEnv: association list mapping entVars to slots *)
257 :     and slotEnv = (EP.entVar * slot) list
258 :    
259 :    
260 :     (* debugging *)
261 :     fun instToString inst =
262 :     (case inst
263 :     of FinalStr{sign,stamp,slotEnv,finalEnt,expanded} =>
264 :     "FinalStr(" ^ signName(sign) ^ ")"
265 :     | PartialStr{sign,path,slotEnv,comps,depth,final_rep} =>
266 :     "PartialStr(" ^ IP.toString path ^ ")"
267 :     | InitialStr{sign,sigDepth,path,slotEnv,inherited,epath} =>
268 :     "InitialStr(" ^ IP.toString path ^ ")"
269 :     | FinalTyc(ref(INST tycon)) =>
270 :     "FinalTyc.INST(" ^ (S.name(TU.tycName tycon)) ^ ")"
271 :     | FinalTyc(ref(NOTINST tycon)) =>
272 :     "FinalTyc.NOTINST(" ^ (S.name(TU.tycName tycon)) ^ ")"
273 :     | PartialTyc{tycon,path,...} => "PartialTyc(" ^ IP.toString path ^ ")"
274 :     | InitialTyc{tycon,path,...} =>
275 :     "InitialTyc(" ^ IP.toString path ^ ")"
276 :     | FinalFct{path, ...} => "FinalFct(" ^ IP.toString path ^ ")"
277 :     | NullTyc => "NullTyc"
278 :     | NullStr => "NullStr"
279 :     | NullFct => "NullFct"
280 :     | ErrorStr => "ErrorStr"
281 :     | ErrorTyc => "ErrorTyc")
282 :    
283 :     fun lookSlot((ev,slot)::rest,ev') =
284 :     if EP.eqEntVar(ev,ev') then slot else lookSlot(rest,ev')
285 :     | lookSlot(nil,_) = bug "lookSlot"
286 :    
287 :     (*
288 :     * Get slot for signature element (tycon or structure) ---
289 : dbm 2737 * Lookup sym in sign, get its entVar, lookup this entVar in slotEnv
290 : blume 902 *)
291 :     fun getElemSlot(sym, SIG {elements,...}, slotEnv) : slot =
292 :     (case MU.getSpecVar(MU.getSpec(elements,sym))
293 :     of SOME v => lookSlot(slotEnv,v)
294 :     | NONE => bug "getElemSlot (1)")
295 :     | getElemSlot _ = bug "getElemSlot (2)"
296 :    
297 :     fun getElemSlots(SIG {elements,...}, slotEnv) : (S.symbol * slot) list =
298 :     let fun f (sym,spec) =
299 :     case MU.getSpecVar spec
300 :     of SOME v => SOME(sym,lookSlot(slotEnv,v))
301 :     | NONE => NONE
302 :     in List.mapPartial f elements
303 :     end
304 :     | getElemSlots _ = bug "getElemSlots"
305 :    
306 :     (* Retrieves all [formal] substructure components from a signature *)
307 :     fun getSubSigs (SIG {elements,...}) =
308 :     List.mapPartial
309 :     (fn (sym,STRspec{sign,entVar,...}) => SOME(sym,entVar,sign)
310 :     | _ => NONE) elements
311 :     | getSubSigs _ = []
312 :    
313 :    
314 :     (* translate a tycon to a tycInst *)
315 :     fun extTycToTycInst tyc =
316 :     case tyc
317 :     of (T.DEFtyc _ | T.PATHtyc _) => NOTINST tyc
318 :     (* may need instantiation -- could check
319 :     * first whether body of DEFtyc contains any
320 :     * PATHtycs -- see bug 1200. *)
321 :     | _ => INST tyc
322 :     (* GENtyc -- won't need instantiation *)
323 :    
324 :     (* getElemDefs : strDef * (unit -> stamp) * int -> (S.symbol * constraint) list
325 :     * returns the definition constraints for components of a strDef,
326 :     * sorted by the component name in ascending order
327 :     *)
328 :     fun getElemDefs (strDef,mkStamp,depth): (S.symbol * constraint) list =
329 :     let val comps =
330 :     (case strDef
331 :     of CONSTstrDef (STR {sign = SIG {elements,...},
332 :     rlzn as {entities,...}, ... }) =>
333 :     List.mapPartial
334 :     (fn (sym,STRspec{sign,entVar,def,slot}) =>
335 :     (debugmsg (">>getElemDefs.C: STRspec " ^
336 :     Symbol.name sym);
337 :     SOME(sym,SDEFINE(CONSTstrDef(
338 :     STR{sign=sign,
339 :     rlzn=EE.lookStrEnt(entities,
340 :     entVar),
341 :     access=A.nullAcc,
342 : blume 2222 prim=[]}),
343 : blume 902 depth))
344 :     before debugmsg ("<<getElemDefs.C: STRspec " ^
345 :     Symbol.name sym))
346 : dbm 2571 | (sym,(TYCspec{entVar,...})) =>
347 : blume 902 (debugmsg (">>getElemDefs.C: TYCspec " ^
348 :     Symbol.name sym);
349 :     let val tyc' = EE.lookTycEnt(entities,entVar)
350 :     val tycInst = extTycToTycInst tyc'
351 :     in debugType("#getElemDefs:TYCspec",tyc');
352 :     SOME(sym,TDEFINE(tycInst,depth))
353 :     end)
354 :     | _ => NONE)
355 :     elements
356 :     | VARstrDef(SIG {elements,...},entPath) =>
357 :     List.mapPartial
358 :     (fn (sym,STRspec{sign,entVar,def,slot}) =>
359 :     (debugmsg (">>getElemDefs.V: STRspec " ^ Symbol.name sym
360 :     ^", entPath: "^EP.entPathToString entPath
361 :     ^", entVar: "^EP.entVarToString entVar);
362 :     SOME(sym,SDEFINE(VARstrDef(sign,entPath@[entVar]),depth)))
363 : dbm 2571 | (sym,TYCspec{entVar,
364 :     info=RegTycSpec{spec=tyc,repl,scope}}) =>
365 :     (debugmsg (">>getElemDefs.V: TYCspec(Reg) " ^ Symbol.name sym
366 : blume 902 ^", entPath: "^EP.entPathToString entPath
367 :     ^", entVar: "^EP.entVarToString entVar);
368 :     SOME(sym,TDEFINE(NOTINST(
369 :     PATHtyc{arity=TU.tyconArity tyc,
370 :     entPath=entPath@[entVar],
371 :     path=TU.tycPath tyc}),
372 :     depth)))
373 : dbm 2571 | (sym,TYCspec{entVar,info=InfTycSpec{name,arity}}) =>
374 :     (debugmsg (">>getElemDefs.V: TYCspec(Inf) " ^ Symbol.name sym
375 :     ^", entPath: "^EP.entPathToString entPath
376 :     ^", entVar: "^EP.entVarToString entVar);
377 :     SOME(sym,TDEFINE(NOTINST(
378 :     PATHtyc{arity=arity,
379 :     entPath=entPath@[entVar],
380 :     path=IP.extend(IP.empty,name)}),
381 :     depth)))
382 : blume 902 | _ => NONE)
383 :     elements
384 :     | CONSTstrDef ERRORstr => nil
385 :     | _ => bug "getElemDefs")
386 :     in ListMergeSort.sort(fn((s1,_),(s2,_)) => S.symbolGt(s1,s2)) comps
387 :     end
388 :    
389 :    
390 :     (* mkElemSlots: Signature * slotEnv * IP.path * entityPath * int
391 :     * -> slotEnv * (S.symbol * slot) list
392 :     *
393 :     * create slots with initial insts for the components of the signature
394 :     * for a structure spec. slots are associated with element names and
395 : dbm 2737 * sorted in ascending order by element name. The slots are also
396 :     * added to the inherited slotEnv, bound to the corresponding element's
397 :     * entityVar, and the augmented slotEnv is returned.
398 : blume 902 *)
399 :     fun mkElemSlots(SIG {elements,...},slotEnv,rpath,epath,sigDepth) =
400 :     let fun mkSlot((sym,STRspec{sign as SIG {closed,...},
401 :     entVar,def,...}),slotEnv) =
402 :     (* a definitional structure spec is translated into a SDEFINE
403 :     * constraint *)
404 :     let val constraints =
405 :     case def
406 :     of NONE => []
407 :     | SOME(strDef,scope) => [SDEFINE(strDef,sigDepth-scope)]
408 :     in SOME (entVar, ref(InitialStr{sign=sign,
409 :     sigDepth=sigDepth,
410 :     path=IP.extend(rpath,sym),
411 :     slotEnv=(if closed then nil
412 :     else slotEnv),
413 :     epath=epath@[entVar],
414 :     inherited=ref constraints}))
415 :     end
416 :     | mkSlot((sym,STRspec{sign as ERRORsig,entVar,...}),slotEnv) =
417 :     SOME (entVar, ref(ErrorStr))
418 : dbm 2571 | mkSlot((sym,TYCspec{entVar,info=RegTycSpec{spec=tycon,repl,scope}}),
419 :     slotEnv) =
420 : blume 902 (case tycon
421 :     of DEFtyc{stamp,path,tyfun=TYFUN{arity,...},...} =>
422 :     (* translate a DEFtyc spec into a TDEFINE constraint *)
423 :     let val tycon' = GENtyc{stamp=stamp,arity=arity,path=path,
424 :     eq=ref(IND),kind=FORMAL,
425 :     stub = NONE}
426 :     in SOME(entVar,
427 :     ref(InitialTyc
428 :     {tycon=tycon',
429 :     path=IP.extend(rpath,sym),
430 :     epath=epath@[entVar],
431 :     inherited=ref[TDEFINE(NOTINST tycon,
432 :     sigDepth-scope)]}))
433 :     end
434 :     | _ =>
435 :     SOME(entVar,
436 :     ref(InitialTyc{tycon=tycon,
437 :     path=IP.extend(rpath,sym),
438 :     epath=epath@[entVar],
439 :     inherited=ref []})))
440 :     | mkSlot((sym,FCTspec{sign,entVar,...}),slotEnv) =
441 :     SOME (entVar,ref(FinalFct{sign=sign, def=ref NONE,
442 :     epath=epath@[entVar],
443 :     path=IP.extend(rpath,sym)}))
444 :     | mkSlot _ = NONE (* value element *)
445 :    
446 :     fun mkSlots(nil,slotEnv,slots) =
447 : dbm 2737 (slotEnv, ListMergeSort.sort
448 :     (fn((s1,_),(s2,_)) => S.symbolGt(s1,s2)) slots)
449 : blume 902 | mkSlots((element as (sym,_))::rest,slotEnv,slots) =
450 :     (case mkSlot(element,slotEnv)
451 :     of SOME(binder as (_,slot)) =>
452 :     mkSlots(rest, binder::slotEnv, (sym,slot)::slots)
453 :     | NONE => mkSlots(rest, slotEnv, slots))
454 :    
455 :     in mkSlots(elements,slotEnv,nil)
456 :     end
457 :     | mkElemSlots _ = bug "mkElemSlots"
458 :    
459 :    
460 :     (* debugging wrappers
461 :     val getSubSigs = wrap "getSubSigs" getSubSigs
462 :     val getElemDefs = wrap "getElemDefs" getElemDefs
463 :     val mkElemSlots = wrap "mkElemSlots" mkElemSlots
464 :     *)
465 :    
466 :     (* propDefs : (symbol * slot) list * (symbol * constraint) list -> unit
467 :     *
468 :     * Propogate definition constraints down to the components of a
469 :     * structure node that has a definition constraint. Called only
470 :     * in constrain in buildStrClass, i.e. when propogating constraints
471 :     * to children of a node.
472 :     *
473 :     * NOTE: does not check that each element in the first list has
474 :     * an associated constraint in the second list.
475 :     *
476 : dbm 2739 * ASSERT: both arguments of propDefs are sorted in ascending order by the
477 :     * symbol component (the arguments are produced by mkElementSlots and
478 : blume 902 * getElemDefs, respectively).
479 :     *
480 :     * ASSERT: all constraints in the second argument are SDEFINE or TDEFINE,
481 :     * as appropriate.
482 :     *)
483 :     fun propDefs(nil,_) = ()
484 :     | propDefs(_,nil) = ()
485 :     | propDefs(a1 as (sym1,sl)::rest1, a2 as (sym2,def)::rest2) =
486 :     if S.symbolGt(sym1,sym2) then propDefs(a1,rest2)
487 :     else if S.symbolGt(sym2,sym1) then propDefs(rest1,a2)
488 :     else (case !sl
489 :     of InitialStr {inherited, ...} => push(inherited, def)
490 :     | InitialTyc {inherited, ...} => push(inherited, def)
491 :     | ErrorStr => (error_found := true)
492 :     | ErrorTyc => ()
493 :     | _ => bug "propDefs";
494 :     propDefs(rest1,rest2))
495 :    
496 :    
497 :     (* propSharing : (S.symbol * slot) list * (S.symbol * slot) list -> unit
498 :     *
499 : dbm 2737 * Propogates inherited sharing constraints (SHARE) to the common
500 :     * elements of two structure nodes that are made to share by addInst
501 :     * (in buildStrClass).
502 : blume 902 *
503 :     * ASSERT: both arguments of propSharing are sorted in assending order by the
504 :     * symbol component.
505 :     *
506 :     * ASSERT: matching slots are either both InitialStr, both InitialTyc,
507 :     * or one is ErrorStr or ErrorTyc.
508 :     *)
509 :     fun propSharing(nil,_,_) = ()
510 :     | propSharing(_,nil,_) = ()
511 :     | propSharing(a1 as (sym1,slot1)::rest1,
512 :     a2 as (sym2,slot2)::rest2,
513 :     depth) =
514 :     if S.symbolGt(sym1,sym2) then propSharing(a1,rest2,depth)
515 :     else if S.symbolGt(sym2,sym1) then propSharing(rest1,a2,depth)
516 :     else (case (!slot1, !slot2)
517 :     of (InitialStr {inherited=inherited1, ...},
518 :     InitialStr {inherited=inherited2, ...}) =>
519 :     (push(inherited1,
520 :     SHARE{my_path=SP.empty,its_ancestor=slot2,
521 :     its_path=SP.empty,depth=depth});
522 :     push(inherited2,
523 :     SHARE{my_path=SP.empty,its_ancestor=slot1,
524 :     its_path=SP.empty,depth=depth}))
525 :     | (InitialTyc {inherited=inherited1, ...},
526 :     InitialTyc {inherited=inherited2, ...}) =>
527 :     (push(inherited1,
528 :     SHARE{my_path=SP.empty,its_ancestor=slot2,
529 :     its_path=SP.empty,depth=depth});
530 :     push(inherited2,
531 :     SHARE{my_path=SP.empty,its_ancestor=slot1,
532 :     its_path=SP.empty,depth=depth}))
533 :     | (ErrorStr,_) => ()
534 :     | (_,ErrorStr) => ()
535 :     | (ErrorTyc,_) => ()
536 :     | (_,ErrorTyc) => ()
537 :     | _ => bug "propSharing";
538 :     propSharing(rest1,rest2,depth))
539 :    
540 :    
541 :     (* debugging wrappers
542 :     val propSharing = wrap "propSharing" propSharing
543 :     *)
544 :    
545 :    
546 :     (**************************************************************************
547 : dbm 2737 * distributeS : Signature * slotEnv * int -> unit *
548 : blume 902 * *
549 :     * This function distributes the structure sharing constraints of a *
550 :     * signature to the children of a corresponding node. Note that this *
551 :     * only deals with the explicit constraints. Implied and inherited *
552 :     * constraints are propogated by propSharing and the constrain functions *
553 :     * of buildStrClass and buildTycClass. *
554 :     **************************************************************************)
555 :     exception DistributeS
556 :    
557 : dbm 2737 fun distributeS (sign as SIG {strsharing,...}, slotEnv, sigDepth) =
558 : blume 902 let fun stepPath (SP.SPATH(sym::path)) =
559 :     let val slot = getElemSlot(sym,sign,slotEnv)
560 :     in case !slot
561 :     of InitialStr{inherited, ...} =>
562 :     (SP.SPATH path, inherited, slot)
563 :     | ErrorStr => raise DistributeS
564 :     | _ => bug "distributeS.stepPath 1"
565 :     end
566 :     | stepPath (SP.SPATH []) = bug "distributeS.stepPath 2"
567 :    
568 :     fun distShare (p::rest) =
569 :     let val (p1, h1, slot1) = stepPath p
570 :     fun addConstraints (p2, h2, slot2) =
571 :     (push(h1,SHARE{my_path=p1, its_path=p2, its_ancestor=slot2,
572 :     depth=sigDepth});
573 :     push(h2,SHARE{my_path=p2, its_path=p1, its_ancestor=slot1,
574 :     depth=sigDepth}))
575 :     in app (fn p' => addConstraints (stepPath p')) rest
576 :     end
577 :     | distShare [] = ()
578 :    
579 :     in (app distShare strsharing) handle DistributeS => ()
580 :     end
581 :     | distributeS _ = ()
582 :    
583 :    
584 :     (****************************************************************************
585 : dbm 2737 * distributeT : Signature * slotEnv * (unit->stamp) * int -> unit *
586 : blume 902 * *
587 : dbm 2737 * This function distributes the signature's type sharing constraints *
588 :     * into the inherited fields of the instances for the children of the *
589 :     * corresponding node. *
590 : blume 902 ****************************************************************************)
591 :     exception DistributeT
592 :    
593 :     fun distributeT (sign as SIG {typsharing,...},
594 : dbm 2737 slotEnv, mkStamp, sigDepth) =
595 : blume 902 let fun stepPath(SP.SPATH[sym]) =
596 :     let val slot = getElemSlot(sym,sign,slotEnv)
597 :     in case !slot
598 :     of InitialTyc {inherited, ...} =>
599 :     (SP.SPATH[], inherited, slot)
600 :     | ErrorTyc => raise DistributeT
601 :     | _ => bug "distributeT:stepPath 1"
602 :     end
603 :     | stepPath(SP.SPATH(sym::path)) =
604 :     let val slot = getElemSlot(sym,sign,slotEnv)
605 :     in case !slot
606 :     of InitialStr {inherited, ...} =>
607 :     (SP.SPATH path, inherited, slot)
608 :     | ErrorStr => raise DistributeT
609 :     | _ => bug "distributeT:stepPath 2"
610 :     end
611 :     | stepPath _ = bug "distributeT:stepPath 3"
612 :    
613 :     fun distShare (p::rest) =
614 :     let val (p1,h1,slot1) = stepPath p
615 :     (* stepPath might raise MU.Unbound if there were errors
616 :     in the signature (testing/modules/tests/101.sml) *)
617 : dbm 2737 fun addConstraints (p2, h2, slot2) =
618 : blume 902 (push(h1,SHARE{my_path=p1, its_path=p2, its_ancestor=slot2,
619 :     depth=sigDepth});
620 :     push(h2,SHARE{my_path=p2, its_path=p1, its_ancestor=slot1,
621 :     depth=sigDepth}))
622 : dbm 2737 in app (fn p' => addConstraints (stepPath p')) rest
623 : blume 902 end
624 :     | distShare [] = ()
625 :    
626 :     in (app distShare typsharing) handle DistributeT => ()
627 :     end
628 :     | distributeT _ = ()
629 :    
630 :     (* debugging wrappers
631 :     val distributeS = wrap "distributeS" distributeS
632 :     val distributeT = wrap "distributeT" distributeT
633 :     *)
634 :    
635 :     exception ExploreInst of IP.path
636 :    
637 :    
638 : dbm 2739 (* THIS COMMENT PARTLY OBSOLETE? *)
639 : blume 902 (***************************************************************************
640 : dbm 2739 * buildStrClass : slot * int * (unit -> stamp) * EM.complainer
641 : blume 902 * -> unit
642 :     *
643 :     * The slot argument is assumed to contain an InitialStr.
644 :     * This function computes the equivalence class of the structure
645 :     * element associated with the slot. It proceeds as follows:
646 :     *
647 :     * 1. New slots are created for the elements of the signature.
648 :     *
649 :     * 2. The InitialStr is replaced by a PartialStr.
650 :     *
651 :     * 3. The signature's explicit type and structure sharing constraints are
652 :     * propogated to the member elements using distributeS and distributeT.
653 :     *
654 : dbm 2738 * 4. This node's inherited constraints are processed, using constrain.
655 :     * If a constraint equates an element to this node,
656 : dbm 2739 * the equivalence class is enlarged (using addIns)t or
657 : blume 902 * a definition is set (classDef). If a constraint applies to children
658 : dbm 2737 * of this node, it is propogated to the children. Processing a
659 : blume 902 * sharing constraint may require that an ancestor of the other node
660 :     * in the constraint first be explored by buildStrClass.
661 : dbm 2738 * Once constrain returns, class contains a list of equivalent PartialStr
662 : blume 902 * nodes that constitute the sharing equivalence class of the original
663 :     * node (thisSlot).
664 :     *
665 :     * 5. finalize is applied to the members of the class to turn them
666 :     * into FinalStrs. The FinalStrs are memoized in the PartialStr
667 :     * nodes to insure that equivalent nodes that have the same signature
668 :     * will contain the same FinalStr value.
669 :     *
670 :     * If two slots in the class have nodes that share the same signature,
671 : dbm 2739 * then the slots are made to point to the same PartialStr node. Of course,
672 : blume 902 * the sharing constraints for both must be propogated to the descendants.
673 :     *
674 :     ***************************************************************************)
675 :    
676 :     (* ASSERT: this_slot is an InitialStr *)
677 :     fun buildStrClass (this_slot: slot, classDepth: int,
678 : dbm 2738 mkStamp, err: EM.complainer) : unit =
679 : blume 902 let val class = ref ([this_slot] : slot list) (* the equivalence class *)
680 :     val classDef = ref (NONE : (strDef * int) option)
681 :     val minDepth = ref infinity
682 :     (* minimum signature nesting depth of the sharing constraints used
683 :     * in the construction of the equivalence class. *)
684 :    
685 :     (* for error messages *)
686 :     val this_path =
687 :     case !this_slot
688 :     of InitialStr{path,...} => ConvertPaths.invertIPath path
689 :     | _ => bug "buildTycClass: this_slot not InitialTyc"
690 :    
691 :     (* addInst(old,new,depth);
692 :     * (1) Adds new to the current equivalence class in response to a sharing
693 :     * constraint relating old to new.
694 : dbm 2737 * (2) Converts the new node from InitialStr to PartialStr. Propagates sharing
695 :     * to the respective common components. Propagate downward the sharing
696 :    
697 : blume 902 * constraints in new's signature. Then apply constrain to each of the
698 :     * inherited constraints.
699 :     * depth is the signature nesting depth of this sharing constraint. *)
700 :     fun addInst (old: slot, new: slot, depth: int) : unit =
701 :     (minDepth := Int.min(!minDepth, depth);
702 :     case !new
703 :     of ErrorStr => ()
704 : dbm 2737 | PartialStr {depth, path, ...} =>
705 : blume 902 if (depth = classDepth) then () (* member current class *)
706 :     else raise ExploreInst path (* member of pending class *)
707 : dbm 2737 | InitialStr {sign, sigDepth, path, slotEnv, inherited, epath} =>
708 : blume 902 (case !old
709 : dbm 2737 of (p as (PartialStr{sign=oldSign,
710 :     slotEnv=oldSlotEnv,
711 : blume 902 comps=oldComps,...})) =>
712 : dbm 2737 if eqSig(sign,oldSign) then (* same sig *)
713 : blume 902 (new := p; (* share the old instance *)
714 :     push(class,new); (* add new slot to class *)
715 : dbm 2737 constrain(new,!inherited,sign,oldSlotEnv,path))
716 : blume 902 (* may be new inherited constraints *)
717 : dbm 2737 else (* new has different sig *)
718 : blume 902 (let val sigDepth' = sigDepth + 1
719 : dbm 2737 val (newSlotEnv,newComps) =
720 : blume 902 mkElemSlots(sign,slotEnv,path,epath,sigDepth')
721 :     in new := PartialStr{sign=sign,path=path,
722 : dbm 2737 slotEnv=newSlotEnv,
723 : blume 902 comps=newComps,
724 :     final_rep = ref NONE,
725 :     depth=classDepth};
726 : dbm 2737 push(class,new); (* add new to the class *)
727 : blume 902 propSharing(oldComps,newComps,depth);
728 : dbm 2737 distributeS (sign, newSlotEnv, sigDepth');
729 :     distributeT (sign, newSlotEnv, mkStamp,
730 : blume 902 sigDepth');
731 : dbm 2737 constrain (new, !inherited, sign, newSlotEnv, path)
732 : blume 902 end
733 :     handle (MU.Unbound _) => (* bad sharing paths *)
734 :     (error_found := true;
735 :     new := ErrorStr))
736 :     | ErrorStr => ()
737 :     (* could do more in this case -- all the above
738 :     * except for propSharing *)
739 :     | _ => bug "addInst 1")
740 :     | _ => if !error_found then new := ErrorStr
741 :     else bug "addInst.2")
742 :    
743 : dbm 2737
744 : blume 902 and constrain (oldSlot, inherited, sign, slotEnv, path) =
745 :     (* Class shares with some external structure *)
746 :     let fun constrain1 constraint =
747 :     case constraint
748 :     of (SDEFINE(strDef,depth)) =>
749 :     (debugmsg "constrain: SDEFINE";
750 :     case !classDef
751 :     of SOME _ =>
752 :     (* already defined -- ignore secondary definitions *)
753 :     if !ElabControl.multDefWarn then
754 :     err EM.WARN
755 :     ("multiple defs at structure spec: "
756 :     ^ SP.toString(ConvertPaths.invertIPath path)
757 :     ^ "\n (secondary definitions ignored)")
758 :     EM.nullErrorBody
759 :     else ()
760 :     | NONE =>
761 :     let val comps = case !oldSlot of
762 :     PartialStr x => #comps x
763 :     | _ => bug "constrain:PartialStr"
764 :     in classDef := SOME(strDef,depth);
765 :     propDefs (comps,getElemDefs(strDef,mkStamp,depth))
766 :     end)
767 :    
768 :     (* Class shares with the structure in slot -- explore it *)
769 :     | SHARE{my_path=SP.SPATH[],its_ancestor=newSlot,
770 :     its_path=SP.SPATH [], depth} =>
771 :     (debugmsg "<calling addInst to add member to this equiv class>";
772 :     addInst(oldSlot,newSlot,depth)
773 :     handle (ExploreInst path') =>
774 :     (err EM.COMPLAIN
775 :     "sharing structure with a descendent substructure"
776 :     EM.nullErrorBody;
777 :     newSlot := ErrorStr))
778 :    
779 :     (* Class shares with another structure. Make sure its ancestor
780 :     * has been explored. Then push the constraint down a level.
781 :     *)
782 :     | SHARE{my_path=SP.SPATH[],its_ancestor=slot,
783 :     its_path=SP.SPATH(sym::rest),depth} =>
784 :     (case (!slot)
785 :     of InitialStr _ =>
786 :     (debugmsg "<Having to call buildStrClass on an ancestor \
787 :     \of a node I'm equivalent to.>";
788 : dbm 2738 buildStrClass (slot, (classDepth+1), mkStamp, err)
789 : blume 902 handle (ExploreInst _) => bug "buildStrClass.4")
790 :     | ErrorStr => ()
791 :     | _ => ();
792 :    
793 :     debugmsg "<finished exploring his ancestor>";
794 :    
795 :     case (!slot)
796 :     of FinalStr {sign=sign', slotEnv=slotEnv', ...} =>
797 :     (debugmsg "<calling constrain recursively>";
798 :     constrain (oldSlot,
799 :     [SHARE{my_path=SP.SPATH[], its_path=SP.SPATH rest,
800 :     its_ancestor=getElemSlot(sym,sign',slotEnv'),
801 :     depth=depth}],
802 :     sign, slotEnv, path))
803 :     | PartialStr _ => (* do we need to check depth? *)
804 :     (err EM.COMPLAIN
805 :     "Sharing structure with a descendent substructure"
806 :     EM.nullErrorBody;
807 :     slot := ErrorStr)
808 :     | ErrorStr => ()
809 :     | _ => bug "buildStrClass.5")
810 :    
811 :     (* One of the node's children shares with someone. Push the
812 :     * constraint down to the child now that we are explored.
813 :     *)
814 :     | SHARE{my_path=SP.SPATH(sym::rest),
815 :     its_ancestor, its_path, depth} =>
816 :     let val { elements, ... } =
817 :     case sign of SIG s => s
818 :     | _ => bug "instantiate:constrain:SIG"
819 :     in case MU.getSpec(elements,sym)
820 : dbm 2571 of TYCspec{entVar,info=RegTycSpec{spec=tycon,repl,scope}} =>
821 : blume 902 (* ASSERT: rest = nil *)
822 :     (case !(lookSlot(slotEnv,entVar))
823 :     of InitialTyc {inherited, ...} =>
824 :     push(inherited,
825 :     SHARE{my_path=SP.SPATH[],
826 :     its_ancestor=its_ancestor,
827 :     its_path=its_path,depth=depth})
828 :     | _ => bug "buildStrClass.6")
829 :     | STRspec{entVar,...} =>
830 :     (case !(lookSlot(slotEnv,entVar))
831 :     of InitialStr {inherited, ...} =>
832 :     push(inherited,
833 :     SHARE{my_path=SP.SPATH rest,
834 :     its_ancestor=its_ancestor,
835 :     its_path=its_path,depth=depth})
836 :     | _ => bug "buildStrClass.7")
837 :     | _ => bug "buildStrClass.8"
838 :     end
839 :     | _ => bug "buildStrClass.9"
840 :     in app constrain1 (rev inherited)
841 :     end
842 :    
843 :     (*
844 :     * Converts all of the nodes in the class (which should be PartialStr)
845 :     * to Final nodes. Note that nodes which share the same signature
846 :     * should share the same FinalStr nodes. So, they are memoized using
847 :     * the final_rep field of the PartialStr node.
848 :     *)
849 :     fun finalize (stampInfoRef: stampInfo ref) slot =
850 :     case (!slot)
851 :     of ErrorStr => ()
852 :     | PartialStr {sign, path, slotEnv, final_rep, ...} =>
853 :     (case !final_rep
854 :     of SOME inst => slot := inst
855 :     | NONE =>
856 :     let val finalEnt =
857 :     case !classDef
858 :     of SOME(CONSTstrDef(STR{sign=sign',
859 :     rlzn, ... }),_) =>
860 :     if eqSig(sign,sign') then CONST_ENT rlzn
861 :     else GENERATE_ENT true
862 :     | SOME(VARstrDef(sign',entPath),_) =>
863 :     (* if eqSig(sign,sign') then PATH_ENT(entPath)
864 :     * else ...
865 :     * DBM: removed to fix bug 1445. Even when
866 :     * the signatures are equal, a free entvar
867 :     * reverence can be propogated by the structure
868 :     * declaration. See bug1445.1.sml. *)
869 :     GENERATE_ENT false
870 :     | SOME(CONSTstrDef(ERRORstr),_) =>
871 :     CONST_ENT bogusStrEntity
872 :     | NONE => GENERATE_ENT true
873 :     | _ => bug "buildStrClass.finalize 1"
874 :     val inst =
875 :     FinalStr {sign = sign,
876 :     stamp = stampInfoRef,
877 :     slotEnv = slotEnv,
878 :     finalEnt = ref finalEnt,
879 :     expanded = ref false}
880 :     in final_rep := SOME inst; (* memoize *)
881 :     slot := inst
882 :     end)
883 :     | _ => bug "buildStrClass.finalize 2"
884 :    
885 :     (* Should find everyone in the equiv. class and convert them to
886 :     * PartialStr nodes.
887 :     *)
888 :     in (* explore equivalence class, filling the class ref with a
889 :     * list of PartialStr insts *)
890 :     case !this_slot (* verify that this_slot is InitialStr *)
891 :     of (InitialStr {sign, sigDepth, path, slotEnv, inherited, epath}) =>
892 :     (let val sigDepth' = sigDepth + 1
893 :     val (slotEnv',newComps) =
894 :     mkElemSlots(sign,slotEnv,path,epath,sigDepth')
895 :     in this_slot :=
896 :     PartialStr{sign=sign,path=path,
897 :     slotEnv=slotEnv',
898 :     comps=newComps,
899 :     final_rep = ref NONE,
900 :     depth=classDepth};
901 : dbm 2737 distributeS (sign, slotEnv', sigDepth');
902 :     distributeT (sign, slotEnv', mkStamp, sigDepth');
903 : blume 902 constrain (this_slot, !inherited, sign, slotEnv', path)
904 :     end
905 :     handle (MU.Unbound _) => (* bad sharing paths *)
906 :     (error_found := true;
907 :     this_slot := ErrorStr))
908 :    
909 :     | _ => bug "buildStrClass.10"; (* not InitialStr *)
910 :    
911 :     (* BUG: needs fixing. DBM *)
912 :     (* verify that any class definition is defined outside of the
913 :     * outermost sharing constraint *)
914 :     case !classDef
915 :     of NONE => () (* no definition - ok *)
916 :     | SOME(_,depth) =>
917 :     if !minDepth <= depth
918 :     then (if !ElabControl.shareDefError
919 :     then classDef := SOME(CONSTstrDef ERRORstr,0)
920 :     else ();
921 :     err (if !ElabControl.shareDefError
922 :     then EM.COMPLAIN
923 :     else EM.WARN)
924 :     ("structure definition spec inside of sharing at: "^
925 :     SymPath.toString this_path)
926 :     EM.nullErrorBody)
927 :     else ();
928 :    
929 :     let val classStampInfo =
930 :     ref(case !classDef
931 :     of SOME(CONSTstrDef str,_) => STAMP(MU.getStrStamp str)
932 :     | SOME(VARstrDef(_,entPath),_) => PATH(entPath)
933 :     | NONE => GENERATE)
934 :    
935 :     in app (finalize classStampInfo) (!class)
936 :     end
937 :     end (* buildStrClass *)
938 :    
939 :     (* debugging wrappers
940 :     val buildStrClass = wrap "buildStrClass" buildStrClass
941 :     *)
942 :    
943 :     exception INCONSISTENT_EQ
944 :     (* raised if tycons with both YES and NO eqprops are found in an
945 :     * equivalence class *)
946 :    
947 :     (*************************************************************************
948 :     * buildTycClass: int * slot * entityEnv * instKind * rpath * (unit->stamp)
949 : dbm 2739 * * EM.complainer
950 : dbm 3045 * -> (tycon * entPath) option
951 : blume 902 *
952 :     * This function deals with exploration of type nodes in the instance
953 :     * graph. It is similar to the buildStrClass function above, but it is
954 :     * simpler since it doesn't have to worry about "children" of
955 :     * type nodes. However, we must check that the arities of equivalenced
956 :     * types are the same. Also, if they have constructors, we must check
957 :     * to see that they have the same constructor names. We don't know how
958 :     * to check that the types of the constructors are satisfiable -- this
959 :     * involves a limited form of second-order unification.
960 :     *
961 :     * But then, probably we should only allow two datatypes to be shared if their
962 :     * types are completely equivalent; otherwise, the behavior of the elaboration
963 :     * would be rather odd sometimes. (ZHONG)
964 :     *
965 : dbm 2739 * buildTycClass is only called once, in the InitialTyc case of expandInst
966 :     * in expand in sigToInst
967 : blume 902 *************************************************************************)
968 :    
969 : dbm 2739 (* ASSERT: this_slot is an InitialTyc
970 :     * This is clearly true given that buildTycClass is only called in
971 :     * a case branch (in expandInst) where the pattern is InitialTyc *)
972 : dbm 2738 fun buildTycClass (cnt, this_slot, instKind, rpath, mkStamp, err) =
973 : blume 902 let val class = ref ([] : slot list)
974 :     val classDef = ref (NONE : (tycInst * int) option)
975 :     val minDepth = ref infinity
976 :     (* minimum signature nesting depth of the sharing constraints used
977 :     * in the construction of the equivalence class. *)
978 :    
979 :     (* for error messages *)
980 :     val this_path =
981 :     case !this_slot
982 :     of InitialTyc{path,...} => ConvertPaths.invertIPath path
983 :     | _ => bug "buildTycClass: this_slot not InitialTyc"
984 :    
985 :     fun addInst (slot,depth)=
986 :     (minDepth := Int.min(!minDepth, depth);
987 :     case !slot
988 :     of InitialTyc {tycon, path, epath, inherited} =>
989 :     (debugmsg "<setting InitialTyc to PartialTyc>";
990 :     slot := PartialTyc{tycon=tycon, path=path, epath=epath};
991 :     push(class,slot);
992 :     app constrain (rev(!inherited)))
993 :     | PartialTyc _ => ()
994 :     | ErrorTyc => ()
995 :     | _ => bug "buildTycClass.addInst")
996 :    
997 :     and constrain (def as TDEFINE(d as (tycInst2,depth))) =
998 :     (case !classDef
999 :     of SOME _ =>
1000 :     (* already defined -- ignore secondary definitions *)
1001 :     if !ElabControl.multDefWarn then
1002 :     err EM.WARN
1003 :     ("multiple defs at tycon spec: "
1004 :     ^ SP.toString(ConvertPaths.invertIPath rpath)
1005 :     ^ "\n (secondary definitions ignored)")
1006 :     EM.nullErrorBody
1007 :     else ()
1008 :     | NONE => classDef := SOME d)
1009 :    
1010 :     | constrain (SHARE{my_path=SP.SPATH[], its_ancestor=slot,
1011 :     its_path=SP.SPATH[], depth}) =
1012 :     addInst(slot,depth)
1013 :    
1014 :     | constrain (SHARE{my_path=SP.SPATH[],its_ancestor=slot,
1015 :     its_path=SP.SPATH(sym::rest),depth}) =
1016 :     (case !slot
1017 :     of InitialStr _ =>
1018 : dbm 2738 (buildStrClass (slot, 0, mkStamp, err)
1019 : blume 902 handle ExploreInst _ => bug "buildTycClass.2")
1020 :     | _ => ();
1021 :    
1022 :     case !slot
1023 :     of FinalStr{sign, slotEnv, ...} =>
1024 :     constrain (SHARE{my_path=SP.SPATH[], its_path=SP.SPATH rest,
1025 :     its_ancestor=getElemSlot(sym,sign,slotEnv),
1026 :     depth=depth})
1027 :     | ErrorStr => ()
1028 :     | _ => bug "buildTycClass.3")
1029 :    
1030 :     | constrain _ = bug "buildTycClass:constrain.4"
1031 :    
1032 :    
1033 :     fun checkArity (ar1, ar2, path1: IP.path, path2: IP.path) =
1034 :     if ar1 = ar2 then true
1035 :     else (err EM.COMPLAIN
1036 :     ("inconsistent arities in type sharing "
1037 :     ^(pathName path1)^" = "^(pathName path2)^" : "
1038 :     ^(pathName path1)^" has arity "^(Int.toString ar1)^" and "
1039 :     ^(pathName path2)^" has arity "^(Int.toString ar2)^".")
1040 :     EM.nullErrorBody;
1041 :     false)
1042 :    
1043 :     val sortD = ListMergeSort.sort
1044 :     (fn ({name=name1,rep=_,domain=_},{name=name2,rep=_,domain=_}) =>
1045 :     S.symbolGt(name1,name2))
1046 :    
1047 :     fun eqDataCons({name=name1,rep=_,domain=_},{name=name2,rep=_,domain=_}) =
1048 :     S.eq(name1,name2)
1049 :    
1050 :     fun compareD ([], []) = true
1051 :     | compareD (d1::r1, d2::r2) =
1052 :     eqDataCons(d1,d2) andalso compareD (r1,r2)
1053 :     | compareD _ = false
1054 :    
1055 :     (* Eta-reduce type abbreviation tycons. Makes sure that DEFtyc is not
1056 :     * just an eta-expansion of another tycon.
1057 :     *)
1058 :     fun simplify(tyc0 as DEFtyc{tyfun=TYFUN{arity,body},...}) =
1059 :     (case body
1060 :     of CONty(RECORDtyc _,args) => tyc0
1061 :     | CONty(tyc,args) =>
1062 :     let fun isvars(IBOUND n ::rest,m) =
1063 :     if n = m then isvars(rest,m+1) else false
1064 :     | isvars (nil,_) = true
1065 :     | isvars _ = bug "simplify:isvars"
1066 :     in if length args = arity andalso
1067 :     isvars(map TU.prune args,0)
1068 :     then simplify tyc else tyc0
1069 :     end
1070 :     | _ => tyc0)
1071 :     | simplify tyc = tyc
1072 :    
1073 :     (*
1074 :     * Potential BUG on equality properties: when selecting the
1075 :     * candidate from a set of FORMAL tycons, the equality property
1076 :     * should be merged ... but this is not done right now (ZHONG)
1077 :     *)
1078 :    
1079 :     fun eqMax((NO, OBJ) |(NO, YES) | (YES, NO) | (OBJ, NO)) =
1080 :     raise INCONSISTENT_EQ
1081 :     | eqMax(_, YES) = YES
1082 :     | eqMax(_, OBJ) = YES
1083 :     | eqMax(ep, _) = ep
1084 :    
1085 :     (* scanForRep scans the tycons in the class, selecting a representative
1086 :     * according to the following rule:
1087 :     * if there is a datatype in the class, select the first one
1088 :     * otherwise, if there is a DEFtyc, select last of these
1089 :     (this case should go away in SML96)
1090 :     * otherwise, all the tycons are FORMAL, select last of these
1091 :     * creates a representative tycon for the class, giving
1092 :     * it a new stamp if it is a datatype or formal. *)
1093 :     fun scanForRep tyc_eps =
1094 :     let fun loop(ERRORtyc,epath,arity,eqprop,(tyc,ep)::rest) =
1095 :     (* initialization *)
1096 :     (case tyc
1097 :     of GENtyc { arity, eq, ... } =>
1098 :     loop(tyc,ep,arity,!eq,rest)
1099 :     | ERRORtyc =>
1100 :     loop(tyc,ep,0,IND,rest)
1101 :     | DEFtyc{tyfun=TYFUN{arity,...},path,...} =>
1102 :     bug "scanForRep 0"
1103 :     | _ => bug "scanForRep 1")
1104 :    
1105 :     | loop(tyc as GENtyc { kind, path = path, ... },
1106 :     epath, arity, eqprop, (tyc', epath') :: rest) =
1107 :     (case kind of
1108 :     DATATYPE _ =>
1109 :     (case tyc'
1110 :     of GENtyc {kind,arity=arity',eq,path=path',...} =>
1111 :     (checkArity(arity,arity',path,path');
1112 :     loop(tyc,epath,arity,eqMax(eqprop,!eq),rest))
1113 :     | ERRORtyc => loop(tyc,epath,arity,eqprop,rest)
1114 :     | DEFtyc{tyfun=TYFUN{arity=arity',...},
1115 :     path=path',...} =>
1116 :     bug "scanForRep 2"
1117 :     | _ => bug "scanForRep 2.1")
1118 :    
1119 :     | FORMAL =>
1120 :     (case tyc'
1121 :     of GENtyc {kind,arity=arity',eq,path=path',...} =>
1122 :     (checkArity(arity,arity',path,path');
1123 :     case kind
1124 :     of DATATYPE _ =>
1125 :     loop(tyc',epath',arity,
1126 :     eqMax(eqprop,!eq),rest)
1127 :     | _ => loop(tyc,epath,arity,
1128 :     eqMax(eqprop,!eq),rest))
1129 :     | ERRORtyc => loop(tyc,epath,arity,eqprop,rest)
1130 :     | DEFtyc{tyfun=TYFUN{arity=arity',...},
1131 :     path=path',...} =>
1132 :     bug "scanForRep 3"
1133 :     | _ => bug "scanForRep 3.1")
1134 :     | _ => bug "scanForRep 8")
1135 :     | loop(tyc,epath,arity,eprop,nil) = (tyc,epath,eprop)
1136 :    
1137 :     | loop _ = bug "scanForRep 4"
1138 :    
1139 :     val (reptyc,epath,eqprop) =
1140 :     case tyc_eps
1141 :     of [(tyc,epath)] =>
1142 :     let val eqprop =
1143 :     case tyc
1144 :     of GENtyc {eq, ...} => !eq
1145 :     | DEFtyc{tyfun=TYFUN{arity,...},...} => IND
1146 :     | ERRORtyc => IND
1147 :     | _ => bug "scanForRep 5"
1148 :     in (tyc,epath,eqprop)
1149 :     end
1150 :     | _ => loop(ERRORtyc,nil,0,IND,tyc_eps)
1151 :     in
1152 :     case reptyc
1153 :     of GENtyc {kind,arity,eq,path,...} =>
1154 :     (case kind
1155 :     of FORMAL =>
1156 : dbm 3291 let val knd =
1157 :     case instKind
1158 :     of INST_ABSTR {entities,...} =>
1159 :     T.ABSTRACT(EE.lookTycEP (entities, epath))
1160 :     | INST_FORMAL => T.FORMAL
1161 : blume 902 val tyc = GENtyc{stamp=mkStamp(), arity=arity,
1162 :     path=IP.append(rpath,path),
1163 :     kind=knd, eq=ref(eqprop),
1164 :     stub = NONE}
1165 : gkuan 2961 in (FinalTyc(ref(INST tyc)), SOME(tyc,epath))
1166 : blume 902 end
1167 :     | DATATYPE _ =>
1168 :     let val tyc = GENtyc{stamp=mkStamp(), kind=kind,
1169 :     arity=arity, stub = NONE,
1170 :     eq=ref(eqprop), path=path}
1171 :     in (FinalTyc(ref(NOTINST tyc)), NONE)
1172 :     (* domains of dataconstructors will be instantiated
1173 :     * in instToTyc *)
1174 :     end
1175 :     | _ => bug "scanForRep 9")
1176 :     | ERRORtyc => (FinalTyc(ref(INST ERRORtyc)), NONE)
1177 :     | DEFtyc _ => bug "scanForRep 6"
1178 :     | _ => bug "scanForRep 7"
1179 : gkuan 2735 end (* fun scanForRep *)
1180 : blume 902
1181 :     fun getSlotEp slot =
1182 :     case !slot
1183 :     of PartialTyc{tycon, epath, ...} => (tycon, epath)
1184 :     | ErrorTyc => (ERRORtyc, nil: EP.entPath)
1185 :     | _ => bug "getSlotEp"
1186 :    
1187 :     fun finalize(defOp,slots) =
1188 :     let val (finalInst, tcOp) =
1189 :     case defOp
1190 :     of SOME(tycInst,_) => (FinalTyc(ref(tycInst)), NONE)
1191 :     | NONE =>
1192 :     (scanForRep(map getSlotEp slots)
1193 :     handle INCONSISTENT_EQ =>
1194 :     (err EM.COMPLAIN
1195 :     "inconsistent equality properties in type sharing"
1196 :     EM.nullErrorBody;
1197 :     (ErrorTyc,NONE)))
1198 :     in app (fn sl => sl := finalInst) slots;
1199 :     tcOp
1200 :     end
1201 :    
1202 :     val _ = addInst(this_slot,infinity)
1203 :    
1204 :     (* DBM: needs fixing (like the similar case in buildStrClass) *)
1205 :     (* verify that any class definition is defined outside of the
1206 :     * outermost sharing constraint *)
1207 :     val _ = case !classDef
1208 :     of NONE => () (* no definition - ok *)
1209 :     | SOME(_,depth) =>
1210 :     if !minDepth <= depth
1211 :     then (if !ElabControl.shareDefError
1212 :     then classDef := SOME(INST(ERRORtyc),0)
1213 :     else ();
1214 :     err (if !ElabControl.shareDefError
1215 :     then EM.COMPLAIN
1216 :     else EM.WARN)
1217 :     ("type definition spec inside of sharing at: "^
1218 :     SymPath.toString this_path)
1219 :     EM.nullErrorBody)
1220 :     else ()
1221 :    
1222 :     in finalize(!classDef,!class)
1223 :     end (* buildTycClass *)
1224 :    
1225 :     (* debugging wrapper
1226 :     val buildTycClass = wrap "buildTycClass" buildTycClass
1227 :     *)
1228 :    
1229 : dbm 2738 fun sigToInst (ERRORsig, instKind, rpath, err, compInfo) =
1230 : dbm 3291 (ErrorStr,[],[])
1231 : dbm 2738 | sigToInst (sign, instKind, rpath, err,
1232 : blume 902 compInfo as {mkStamp,...}: EU.compInfo) =
1233 : dbm 2739 let val flextycs : T.tycon list ref = ref [] (* the "abstract" tycons *)
1234 : gkuan 2961 val flexeps : EP.entPath list ref = ref []
1235 : dbm 2739 (* the tkind environment *)
1236 : blume 902 val cnt = ref 0
1237 :    
1238 : dbm 2739 (* addbt: collects tycons and entity path -> tkind bindings
1239 :     produced by calls of buildTycClass below *)
1240 : blume 902 fun addbt NONE = ()
1241 : gkuan 2961 | addbt (SOME (tyc,ep)) =
1242 : dbm 2739 (flextycs := (tyc::(!flextycs));
1243 : gkuan 2961 flexeps := (ep::(!flexeps));
1244 : blume 902 cnt := ((!cnt) + 1))
1245 :    
1246 :     fun expand ErrorStr = ()
1247 :     | expand (FinalStr {expanded=ref true,...}) = ()
1248 :     | expand (FinalStr {sign,slotEnv,expanded,...}) =
1249 :     (*
1250 :     * We must expand the FinalStr inst in a top-down
1251 :     * fashion. So, we iterate through the bindings.
1252 :     * As we encounter structure or type element, we recursively
1253 :     * expand it.
1254 :     *)
1255 :     let fun expandInst (sym,slot) =
1256 :     (debugmsg("<Expanding element " ^ S.symbolToString sym ^ ">");
1257 :     case !slot
1258 :     of InitialStr _ =>
1259 :     (debugmsg("--expandInst: exploring InitialStr "^
1260 :     S.name sym);
1261 : dbm 2738 buildStrClass (slot, 0, mkStamp, err)
1262 : blume 902 handle ExploreInst _ => bug "expandInst 1";
1263 :    
1264 :     case !slot
1265 :     of (inst as (FinalStr _)) =>
1266 :     (debugmsg("--expandInst: expanding new FinalStr "^
1267 :     S.name sym);
1268 :     expand inst)
1269 :     | ErrorStr => ()
1270 :     | _ => bug "expand_substr 2")
1271 :     | PartialStr{path,...} =>
1272 :     bug ("expandInst: PartialStr "^IP.toString path)
1273 :     | inst as FinalStr _ =>
1274 :     (debugmsg("--expandInst: expanding old FinalStr "^
1275 :     S.name sym);
1276 :     expand inst)
1277 :     | InitialTyc _ =>
1278 : dbm 2738 addbt(buildTycClass(!cnt, slot, instKind,
1279 : blume 902 rpath, mkStamp, err))
1280 :     | _ => ())
1281 :    
1282 :     in debugmsg ">>expand"; expanded := true;
1283 :     app expandInst (getElemSlots(sign,slotEnv));
1284 :     debugmsg "<<expand"
1285 :     end
1286 :     | expand _ = bug "expand"
1287 :    
1288 :     val baseSlot = ref(InitialStr{sign=sign, sigDepth=1, path=rpath, epath=[],
1289 :     inherited=ref [], slotEnv=nil})
1290 :     (* correct initial value for sigDepth? *)
1291 :    
1292 : dbm 2738 val _ = buildStrClass(baseSlot, 0, mkStamp, err)
1293 : blume 902 handle (ExploreInst _) => bug "sigToInst 2"
1294 :    
1295 :     val strInst = !baseSlot
1296 :     val _ = expand strInst
1297 :    
1298 : dbm 3291 in (strInst, !flextycs, !flexeps)
1299 : blume 902 end (* fun sigToInst *)
1300 :    
1301 :     exception Get_Origin (* who is going to catch it? *)
1302 :    
1303 :     fun get_stamp_info instance =
1304 :     case instance
1305 :     of (FinalStr {stamp,...}) => stamp
1306 :     | ErrorStr => raise Get_Origin
1307 :     | _ => bug "get_stamp_info"
1308 :    
1309 :    
1310 : gkuan 2961 fun instToStr (instance, entEnv, instKind, rpath: IP.path, err,
1311 : blume 902 compInfo as {mkStamp, ...}: EU.compInfo)
1312 :     : M.strEntity =
1313 :     let fun instToStr' (instance as (FinalStr{sign as SIG {closed, elements,... },
1314 :     slotEnv,finalEnt,stamp,...}),
1315 :     entEnv, rpath: IP.path, failuresSoFar: int)
1316 :     : M.strEntity * int =
1317 :     (debugmsg (">>instToStr': " ^ IP.toString rpath);
1318 :     case !finalEnt
1319 :     of CONST_ENT strEnt => (strEnt,failuresSoFar) (* already visited *)
1320 :     | PATH_ENT ep =>
1321 :     (let val strEnt = EE.lookStrEP(entEnv,ep)
1322 :     in finalEnt := CONST_ENT strEnt;
1323 : dbm 2737 (strEnt,failuresSoFar)
1324 : blume 902 end
1325 : dbm 2737 handle EE.Unbound =>
1326 :     (debugmsg ("instToStr':PATH_ENT failed: "^
1327 :     EP.entPathToString ep);
1328 :     raise EE.Unbound))
1329 : blume 902 | GENERATE_ENT closedDef =>
1330 :     let
1331 :     (* Gets the stamp of an instance -- generates one if
1332 :     * one is not already built. *)
1333 :     fun getStamp instance : Stamps.stamp =
1334 :     let val stamp = get_stamp_info instance
1335 :     in case (!stamp)
1336 :     of STAMP s => (debugmsg "getStamp:STAMP"; s)
1337 :     | PATH ep =>
1338 :     (debugmsg ("getStamp:PATH "^EntPath.entPathToString ep);
1339 :     (let val {stamp=s,...} = EE.lookStrEP(entEnv,ep)
1340 :     in stamp := STAMP s; s
1341 :     end
1342 : dbm 2737 handle EE.Unbound => (debugmsg "getStamp:PATH failed";
1343 : blume 902 raise EE.Unbound)))
1344 :     | GENERATE =>
1345 :     let val s = mkStamp()
1346 :     in debugmsg "getStamp:GENERATE";
1347 : dbm 2737 stamp := STAMP s; s
1348 : blume 902 end
1349 :     end
1350 :    
1351 :     fun instToTyc(ref(INST tycon),_) = tycon
1352 :     (* already instantiated *)
1353 : dbm 2737 | instToTyc(r as ref(NOTINST tycon), entEnv) =
1354 :     let fun badtycon () = (* bogus tycon *)
1355 : blume 902 (debugType("#instToTyc(NOTINST/bogus)",tycon);
1356 :     r := INST ERRORtyc;
1357 :     ERRORtyc)
1358 :     in
1359 :     case tycon
1360 :     of T.DEFtyc{tyfun=T.TYFUN{arity, body},strict,
1361 :     stamp,path} =>
1362 :     (* DEFtyc body gets instantiated here *)
1363 :     (* debugging version *)
1364 :     (let val tc =
1365 :     (* if repl
1366 :     then (* eta reduce wrapped datatype *)
1367 :     let val T.CONty(tyc,_) = body
1368 :     in MU.transTycon entEnv tyc
1369 :     end
1370 : dbm 2737 else *)
1371 :     let val tf =
1372 :     T.TYFUN{arity=arity,
1373 :     body=MU.transType entEnv body}
1374 :     in T.DEFtyc{tyfun=tf, strict=strict,
1375 :     stamp=mkStamp(),
1376 :     path=IP.append(rpath,path)}
1377 :     end
1378 : blume 902 in debugType("#instToTyc(NOTINST/DEFtyc)",tc);
1379 :     r := INST tc;
1380 :     tc
1381 : dbm 2737 end
1382 :     handle EE.Unbound =>
1383 : blume 902 (debugmsg "#instToTyc(NOTINST/DEFtyc) failed";
1384 :     raise EE.Unbound))
1385 :    
1386 :     | T.GENtyc {stamp,arity,eq,path,kind,...} =>
1387 :     (case kind of
1388 :     z as T.DATATYPE {index,freetycs,stamps,
1389 :     family, root} =>
1390 :     (let
1391 :     (* no coordination of stamps between mutually
1392 :     * recursive families of datatypes? *)
1393 :     val nstamps =
1394 :     (case root
1395 :     of NONE =>
1396 :     (* this is the lead dt of family *)
1397 :     Vector.map
1398 :     (fn _ => mkStamp()) stamps
1399 :     | SOME rootev =>
1400 :     (* this is a secondary dt of a family,
1401 :     * find the stamp vector for the root
1402 :     * dt of the family, which should already
1403 :     * have been instantiated *)
1404 :     (case EE.lookTycEnt(entEnv, rootev)
1405 :     of T.GENtyc { kind =
1406 :     T.DATATYPE{stamps, ...},
1407 :     ... } => stamps
1408 :     | T.ERRORtyc =>
1409 :     Vector.map
1410 :     (fn _ => mkStamp()) stamps
1411 :     | _ =>
1412 :     (* oops, the root instantiation
1413 :     * is not a datatype (see bug 1414) *)
1414 :     bug "unexpected DATATYPE 354"))
1415 :     val s = Vector.sub(nstamps, index)
1416 :     val nfreetycs =
1417 :     map (MU.transTycon entEnv) freetycs
1418 :    
1419 :     val nkind =
1420 :     T.DATATYPE{index=index,
1421 :     family=family,
1422 :     stamps=nstamps,
1423 :     freetycs=nfreetycs,
1424 :     root=NONE} (* root ??? *)
1425 :    
1426 :     val tc =
1427 :     T.GENtyc{stamp=s, arity=arity, eq=eq,
1428 :     path=IP.append(rpath,path),
1429 :     kind=nkind,stub=NONE}
1430 :    
1431 :     in
1432 :     r := INST tc;
1433 :     tc
1434 :     end handle EE.Unbound =>
1435 :     (debugmsg "#instToTyc(NOTINST/DATA) failed";
1436 :     raise EE.Unbound))
1437 :     | _ => badtycon ())
1438 :     | PATHtyc{entPath,...} =>
1439 :     (let val _ =
1440 :     debugmsg ("#instToTyc(NOTINST/PATHtyc): "^
1441 :     EP.entPathToString entPath)
1442 :     val tyc = EE.lookTycEP(entEnv,entPath)
1443 :     in
1444 :     r := INST tyc;
1445 :     tyc
1446 :     end
1447 :     handle EE.Unbound =>
1448 :     (debugmsg "#instToTyc(NOTINST/PATHtyc) failed";
1449 :     raise EE.Unbound))
1450 :     | _ => badtycon ()
1451 :     end
1452 :    
1453 :     (*
1454 :     * Creates an entity from the instance node found
1455 :     * in the given slot.
1456 :     *)
1457 :     fun instToEntity (sym,slot,entEnv,failuresSoFar:int)
1458 :     : M.entity * int =
1459 :     (debugmsg ("instToEntity: "^Symbol.name sym^" "^
1460 :     Int.toString failuresSoFar);
1461 :     case !slot
1462 :     of (inst as (FinalStr _)) =>
1463 :     let val (strEntity,n) =
1464 :     instToStr'(inst, entEnv, IP.extend(rpath,sym),
1465 :     failuresSoFar)
1466 :     in (STRent strEntity, n)
1467 :     end
1468 :    
1469 :     | FinalTyc r =>
1470 :     (TYCent(instToTyc(r,entEnv)),failuresSoFar)
1471 :    
1472 : gkuan 3006 | FinalFct{sign as FSIG{paramvar,paramsig,bodysig,...},
1473 : blume 902 def, epath, path} =>
1474 :     (case !def
1475 :     of SOME(FCT { rlzn, ... }) => FCTent rlzn
1476 :     (*** would this case ever occur ??? ***)
1477 :    
1478 :     | NONE =>
1479 :     let val stamp = mkStamp()
1480 : gkuan 2961 val (bodyExp) =
1481 : dbm 3291 case instKind
1482 :     of INST_ABSTR {entities,...} =>
1483 :     let val fctEnt = EE.lookFctEP (entities, epath)
1484 :     in M.ABSstr (bodysig,
1485 :     APPLY(CONSTfct fctEnt,
1486 :     VARstr [paramvar]))
1487 :     end
1488 :     | INST_FORMAL => M.FORMstr sign
1489 : gkuan 3344 val (paramRlzn, abstycs, _) =
1490 : gkuan 2751 instGeneric{sign=paramsig, entEnv=entEnv,
1491 :     rpath=path,
1492 :     region=SourceMap.nullRegion,
1493 : dbm 3291 instKind=INST_FORMAL,
1494 : gkuan 3006 compInfo=compInfo}
1495 :     val nenv = EE.mark(mkStamp,
1496 :     EE.bind(paramvar,
1497 :     STRent paramRlzn,
1498 :     entEnv))
1499 : blume 902 val cl = CLOSURE{param=paramvar,
1500 :     body=bodyExp,
1501 :     env=entEnv}
1502 :     in FCTent {stamp = stamp,
1503 :     rpath=path,
1504 : gkuan 3344 primaries = abstycs,
1505 : gkuan 3006 paramRlzn = paramRlzn,
1506 : blume 902 closure=cl,
1507 :     properties = PropList.newHolder (),
1508 :     stub=NONE}
1509 :     end
1510 :    
1511 :     | _ => bug "unexpected functor def in instToStr",
1512 :     failuresSoFar)
1513 :    
1514 :     | ErrorStr => (ERRORent,failuresSoFar)
1515 :     | ErrorTyc => (ERRORent,failuresSoFar)
1516 :     | inst => (say("bad inst: " ^ instToString inst ^ "\n");
1517 :     (ERRORent,failuresSoFar)))
1518 :    
1519 :     (* a DEFtyc entity instantiating a datatype spec (an
1520 :     * explicit or implicit datatype replication spec), must
1521 :     * be unwrapped, so that the instantiation is a datatype.
1522 :     * This replaces the unwrapping that was formerly done
1523 :     * in checkTycBinding in SigMatch. Fixes bugs 1364 and
1524 :     * 1432. [DBM]
1525 :     *)
1526 : dbm 2571 fun fixUpTycEnt (TYCspec{info=RegTycSpec{spec=GENtyc{kind=DATATYPE _,
1527 :     ...},...},...},
1528 : blume 902 TYCent(tyc)) =
1529 :     (* possible indirect datatype repl. See bug1432.7.sml *)
1530 :     TYCent(TU.unWrapDefStar tyc)
1531 : dbm 2571 | fixUpTycEnt (TYCspec{info=RegTycSpec{repl=true,...},...},
1532 :     TYCent(tyc)) =
1533 : blume 902 (* direct or indirect datatype repl. Original spec
1534 :     * was a datatype spec. See bug1432.1.sml *)
1535 :     TYCent(TU.unWrapDefStar tyc)
1536 :     | fixUpTycEnt (_,ent) = ent
1537 :    
1538 :     fun mkEntEnv (baseEntC) =
1539 :     foldl (fn ((sym,spec),(env,failCount)) =>
1540 :     (debugmsg ("mkEntEnv: "^Symbol.name sym);
1541 :     case MU.getSpecVar spec
1542 :     of SOME v =>
1543 :     (let val s = lookSlot(slotEnv,v)
1544 :     val (e,failures) =
1545 :     instToEntity(sym, s, env, failCount)
1546 :     val e = fixUpTycEnt(spec,e)
1547 :     in debugmsg ("ok: "^EP.entVarToString v);
1548 :     (EE.bind(v, e, env), failures)
1549 :     end
1550 :     handle EE.Unbound => (* tycon inst *)
1551 :     (debugmsg ("failed at: "^S.name sym);
1552 :     (env, failCount+1)))
1553 :     | NONE => (env,failCount)))
1554 :     baseEntC elements
1555 :    
1556 :     val (entEnv',failCount) =
1557 :     if closed andalso closedDef
1558 :     then (let val _ = debugmsg "mkEntEnv: closed"
1559 :     val (ee, fc) = mkEntEnv(EE.empty, 0)
1560 :     in (ee, fc+failuresSoFar)
1561 :     end)
1562 :     else (let val _ = debugmsg "mkEntEnv: not closed";
1563 :     val baseEntC =
1564 :     (MARKeenv{stamp = mkStamp(),
1565 :     env = entEnv,
1566 : dbm 3317 stub = NONE},
1567 : blume 902 failuresSoFar)
1568 :     val (ee, fc) = mkEntEnv(baseEntC)
1569 :     in (ee, fc)
1570 :     end)
1571 :    
1572 :     val strEnt={stamp =getStamp instance,
1573 :     rpath=rpath,
1574 :     entities=entEnv',
1575 : dbm 3317 stub=NONE,
1576 :     properties = PropList.newHolder ()}
1577 :    
1578 : blume 902 val _ = debugmsg (String.concat["--instToStr': failuresSoFar = ",
1579 :     Int.toString failuresSoFar,
1580 :     ", failCount = ",
1581 :     Int.toString failCount])
1582 :    
1583 :     in if failCount = 0
1584 :     then finalEnt := CONST_ENT strEnt
1585 :     else ();
1586 :     ED.withInternals(fn () =>
1587 :     ED.debugPrint debugging
1588 :     (("<<instToStr':" ^ IP.toString rpath^":"),
1589 :     (fn ppstrm => fn ent =>
1590 :     PPModules.ppEntity ppstrm (ent, StaticEnv.empty, 20)),
1591 :     M.STRent strEnt));
1592 :     (strEnt, failCount)
1593 :     end)
1594 :     | instToStr'(ErrorStr, _, _, failuresSoFar) =
1595 :     (bogusStrEntity,failuresSoFar)
1596 :     | instToStr' _ = bug "instToStr - instance not FinalStr"
1597 :    
1598 :     fun loop(strEnt,failures) =
1599 :     (debugmsg ("instToStr': failures = " ^ Int.toString failures);
1600 :     if failures = 0
1601 :     then strEnt
1602 :     else let val (strEnt',failures') =
1603 :     instToStr'(instance,entEnv,rpath,0)
1604 :     in if failures' < failures
1605 :     then loop(strEnt',failures')
1606 :     else (err EM.COMPLAIN "dependency cycle in instantiate"
1607 :     EM.nullErrorBody;
1608 :     strEnt')
1609 :     end)
1610 :     in loop(instToStr'(instance,entEnv,rpath,0))
1611 :     end (* fun instToStr *)
1612 :    
1613 :     (*** fetching the TycKind for a particular functor signature ***)
1614 :    
1615 :     (*** the generic instantiation function ***)
1616 : dbm 2739 (* instGeneric :
1617 :     sign : Signature -- the signature to instantiate
1618 :     entEnv : entityEnv -- contextual entityEnv (for open signatures?)
1619 :     instKind : instKind -- kind of instantiation (parameter, formal body, abstr)
1620 :     rpath : InvPath.path -- context symbolic path (?)
1621 :     region: SourceMap.region -- soure region for error messages
1622 :     compInfo : compInfo -- for mkStamp and error
1623 :     ->
1624 : dbm 3291 strEnt : strEntity (str realization)
1625 : gkuan 2961 abs_tycs : tycon list -- tycs introduced by instantiation
1626 :     tyceps : entpath list -- the initial segment of all_eps
1627 : dbm 3291 collected in sigToInst
1628 : dbm 2739 *)
1629 : blume 902 and instGeneric{sign, entEnv, instKind, rpath, region,
1630 :     compInfo as {mkStamp,error,...} : EU.compInfo} =
1631 :     let val _ = debugmsg (">>instantiate: "^signName sign)
1632 :     val _ = error_found := false
1633 :     fun err sev msg = (error_found := true; error region sev msg)
1634 : dbm 3291
1635 :     (* what was this supposed to do???
1636 : blume 902 val baseStamp = mkStamp()
1637 : dbm 3291 *)
1638 :    
1639 :     val (inst, abstycs, tyceps) =
1640 : dbm 2738 sigToInst(sign, instKind, rpath, err, compInfo)
1641 : blume 902
1642 :     val strEnt =
1643 : gkuan 2961 instToStr(inst,entEnv,instKind,rpath,err,compInfo)
1644 : blume 902
1645 : dbm 3291 val tyceps = rev tyceps
1646 : blume 902
1647 : dbm 3291 (* let's memoize the resulting bound tycon entity paths, tyceps *)
1648 : blume 902 val _ = case sign
1649 : dbm 3291 of M.SIG sigrec =>
1650 :     (case ModPropList.sigBoundeps sigrec
1651 :     of NONE => ModPropList.setSigBoundeps (sigrec, SOME tyceps)
1652 :     | _ => ())
1653 : blume 902 | _ => ()
1654 :    
1655 :     val _ = debugmsg "<<instantiate"
1656 : dbm 3291 in (strEnt, rev abstycs, tyceps)
1657 : blume 902 end
1658 :    
1659 :     (* debugging wrappers
1660 :     val sigToInst = wrap "sigToInst" sigToInst
1661 :     val instToStr = wrap "instToStr" instToStr
1662 :     val instGeneric = wrap "instantiate" instGeneric
1663 :     *)
1664 :    
1665 : dbm 3291 (* The exported instantiation functions: instFormal and instAbstr *)
1666 :    
1667 :     (* instFormal and instAbstr when called in EvalEntity will use the
1668 :     * abstycs and tyceps fields of the returned record to augment
1669 :     * an entity path context.
1670 :     * instFormal when called in ElabMod will only use the rlzn field.
1671 :     * instFmBody is called in ElabMod and EvalEntity, while instAbstr
1672 :     * is called in SigMatch and EvalEntity.
1673 :     * In SigMatch, the tyceps field returned by instAbstr is not used.
1674 :     * instFormal replaces the former instParam and instFmBody.
1675 :     *)
1676 :    
1677 : blume 902 (*** instantiation of the formal functor body signatures ***)
1678 : dbm 3291 fun instFormal{sign, entEnv, rpath, region, compInfo} =
1679 :     let val (rlzn, abstycs, tyceps)
1680 :     = instGeneric{sign=sign, entEnv=entEnv, instKind=INST_FORMAL,
1681 : blume 902 rpath=rpath, region=region, compInfo=compInfo}
1682 : gkuan 2961 in {rlzn=rlzn, abstycs=abstycs, tyceps=tyceps}
1683 : blume 902 end
1684 :    
1685 :     (*** instantiation of the structure abstractions **)
1686 :     fun instAbstr{sign, entEnv, srcRlzn, rpath, region, compInfo} =
1687 : dbm 3291 let val (rlzn, abstycs, tyceps)
1688 : blume 902 = instGeneric{sign=sign, entEnv=entEnv, instKind=INST_ABSTR srcRlzn,
1689 :     rpath=rpath, region=region, compInfo=compInfo}
1690 : gkuan 2961 in {rlzn=rlzn, abstycs=abstycs, tyceps=tyceps}
1691 : blume 902 end
1692 :    
1693 : dbm 3291 val instFormal =
1694 :     Stats.doPhase (Stats.makePhase "Compiler 032 instformal") instFormal
1695 : blume 902
1696 :     (*
1697 :     val instAbstr =
1698 :     Stats.doPhase (Stats.makePhase "Compiler 032 3-instAbstr") instAbstr
1699 :     *)
1700 :    
1701 :     end (* local *)
1702 :     end (* structure Instantiate *)
1703 :    
1704 : blume 2222 (* [dbm, 6/16/06] Eliminated ii2ty from INSTANTIATE_PARAM. Eventually want
1705 :     to eliminate the parameterization completely. *)
1706 :    

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