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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 419 - (view) (download)

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

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