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

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