1: # 21 "./lpsrc/flx_inst.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_mtypes1
6: open Flx_mtypes2
7: open Flx_print
8: open Flx_typing
9: open Flx_mbind
10: open Flx_srcref
11: open List
12: open Flx_unify
13: open Flx_treg
14: open Flx_exceptions
15: open Flx_maps
16: open Flx_prop
17:
18: let null_table = Hashtbl.create 3
19:
20: let add_inst syms bbdfns ref_insts1 (i,ts) =
21: (*
22: print_endline ("Attempt to register instance " ^ si i ^ "[" ^
23: catmap ", " (sbt syms.dfns) ts ^ "]");
24: *)
25: let i,ts = Flx_typeclass.fixup_typeclass_instance syms bbdfns i ts in
26: (*
27: print_endline ("remapped to instance " ^ si i ^ "[" ^
28: catmap ", " (sbt syms.dfns) ts ^ "]");
29: *)
30: let x = i, map (fun t -> reduce_type (lstrip syms.dfns t)) ts in
31: let has_variables =
32: fold_left
33: (fun truth t -> truth ||
34: try var_occurs t
35: with _ -> failwith ("[add_inst] metatype in var_occurs for " ^ sbt syms.dfns t)
36: )
37: false
38: ts
39: in
40: if has_variables then
41: failwith
42: (
43: "Attempt to register instance " ^ si i ^ "[" ^
44: catmap ", " (sbt syms.dfns) ts ^
45: "] with type variable in a subscript"
46: )
47: ;
48: if not (FunInstSet.mem x !ref_insts1)
49: && not (Hashtbl.mem syms.instances x)
50: then begin
51: ref_insts1 := FunInstSet.add x !ref_insts1
52: end
53:
54: let rec process_expr syms bbdfns ref_insts1 hvarmap sr ((e,t) as be) =
55: (*
56: print_endline ("Process expr " ^ sbe syms.dfns be ^ " .. raw type " ^ sbt syms.dfns t);
57: print_endline (" .. instantiated type " ^ string_of_btypecode syms.dfns (varmap_subst hvarmap t));
58: *)
59: let ue e = process_expr syms bbdfns ref_insts1 hvarmap sr e in
60: let ui i ts = add_inst syms bbdfns ref_insts1 (i,ts) in
61: let ut t = register_type_r ui syms bbdfns [] sr t in
62: let vs t = varmap_subst hvarmap t in
63: let t' = vs t in
64: ut t'
65: ;
66: (* CONSIDER DOING THIS WITH A MAP! *)
67: begin match e with
68: | `BEXPR_parse (e,ii) ->
69: ue e; iter (fun i -> ui i []) ii
70:
71: | `BEXPR_deref e
72: | `BEXPR_get_n (_,e)
73: | `BEXPR_match_case (_,e)
74: | `BEXPR_case_arg (_,e)
75: | `BEXPR_case_index e
76: -> ue e
77:
78: | `BEXPR_get_named (i,((oe,ot) as obj)) ->
79: (*
80: print_endline "Get named: class member";
81: *)
82: ue obj;
83: (*
84: print_endline "Register object expr";
85: *)
86: (* instantiate member with binding for class type parameters *)
87: begin match ot with
88: | `BTYP_inst (j,ts)
89: | `BTYP_lvalue (`BTYP_inst (j,ts)) ->
90: (*
91: print_endline ("Register member " ^ si i^ ", ts=" ^ catmap "," (sbt syms.dfns) ts);
92: *)
93: let ts = map vs ts in
94: ui i ts
95: | _ -> assert false
96: end
97:
98: | `BEXPR_apply_prim (index,ts,a)
99: | `BEXPR_apply_direct (index,ts,a)
100: | `BEXPR_apply_struct (index,ts,a)
101: | `BEXPR_apply_stack (index,ts,a)
102: | `BEXPR_apply ((`BEXPR_closure (index,ts),_),a) ->
103: (*
104: print_endline "apply direct";
105: *)
106: let id,parent,sr2,entry =
107: try Hashtbl.find bbdfns index
108: with _ -> failwith ("[process_expr(apply instance)] Can't find index " ^ si index)
109: in
110: begin match entry with
111: (* function type not needed for direct call *)
112: | `BBDCL_fun _
113: | `BBDCL_callback _
114: | `BBDCL_function _
115: | `BBDCL_nonconst_ctor _
116: ->
117: let ts = map vs ts in
118: ui index ts; ue a
119: | `BBDCL_procedure _ ->
120: failwith "Use of mangled procedure in expression! (should have been lifted out)"
121:
122: (* the remaining cases are struct/variant type constructors,
123: which probably don't need types either .. fix me!
124: *)
125: (* | _ -> ue f; ue a *)
126: | _ ->
127: (*
128: print_endline "struct component?";
129: *)
130: ui index ts; ue a
131: end
132:
133: | `BEXPR_apply_method_direct (obj,meth,ts,a)
134: | `BEXPR_apply_method_stack (obj,meth,ts,a)
135: | `BEXPR_apply ((`BEXPR_method_closure (obj,meth,ts),_),a) ->
136: (*
137: print_endline "method apply";
138: *)
139: ue obj;
140: ui meth ts;
141: ue a
142:
143: | `BEXPR_apply (e1,e2) ->
144: (*
145: print_endline "Simple apply";
146: *)
147: ue e1; ue e2
148:
149: | `BEXPR_tuple es ->
150: iter ue es;
151: register_tuple syms (vs t)
152:
153: | `BEXPR_record es ->
154: let ss,es = split es in
155: iter ue es;
156: register_tuple syms (vs t)
157:
158: | `BEXPR_variant (s,e) ->
159: ue e
160:
161: | `BEXPR_case (_,t) -> ut (vs t)
162:
163: | `BEXPR_ref (i,ts)
164: | `BEXPR_name (i,ts)
165: | `BEXPR_closure (i,ts)
166: ->
167: (* substitute out display variables *)
168: (*
169: print_endline ("Raw Variable " ^ si i ^ "[" ^ catmap "," (sbt syms.dfns) ts ^ "]");
170: *)
171: let ts = map vs ts in
172: (*
173: print_endline ("Variable with mapped ts " ^ si i ^ "[" ^ catmap "," (sbt syms.dfns) ts ^ "]");
174: *)
175: ui i ts;
176: (*
177: print_endline "Instance done";
178: *)
179: iter ut ts
180: (*
181: ;
182: print_endline "ts done";
183: *)
184:
185: | `BEXPR_new e -> ue e
186:
187: | `BEXPR_method_closure (e,i,ts) ->
188: (*
189: print_endline "method closure";
190: *)
191: ue e;
192: let ts = map vs ts in
193: ui i ts; iter ut ts
194:
195: | `BEXPR_literal _ -> ()
196: | `BEXPR_expr (_,t) -> ut t
197: | `BEXPR_range_check (e1,e2,e3) -> ue e1; ue e2; ue e3
198: | `BEXPR_coerce (e,t) -> ue e; ut t
199: end
200:
201: and process_exe syms bbdfns ref_insts1 ts hvarmap (exe:bexe_t) =
202: let ue sr e = process_expr syms bbdfns ref_insts1 hvarmap sr e in
203: let uis i ts = add_inst syms bbdfns ref_insts1 (i,ts) in
204: let ui i = uis i ts in
205: (*
206: print_endline ("processing exe " ^ string_of_bexe syms.dfns 0 exe);
207: print_endline ("With ts = " ^ catmap "," (sbt syms.dfns) ts);
208: *)
209: (* TODO: replace with a map *)
210: match exe with
211: | `BEXE_axiom_check _ -> assert false
212: | `BEXE_call_prim (sr,i,ts,e2)
213: | `BEXE_call_direct (sr,i,ts,e2)
214: | `BEXE_jump_direct (sr,i,ts,e2)
215: | `BEXE_call_stack (sr,i,ts,e2)
216: ->
217: let ut t = register_type_r uis syms bbdfns [] sr t in
218: let vs t = varmap_subst hvarmap t in
219: let ts = map vs ts in
220: iter ut ts;
221: uis i ts;
222: ue sr e2
223:
224: | `BEXE_call_method_direct (sr,obj,meth,ts,a)
225: | `BEXE_call_method_stack (sr,obj,meth,ts,a) ->
226: let ut t = register_type_r uis syms bbdfns [] sr t in
227: let vs t = varmap_subst hvarmap t in
228: let ts = map vs ts in
229: ue sr obj;
230: iter ut ts;
231: uis meth ts;
232: ue sr a
233:
234: | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2)
235: | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2)
236: ->
237: let ut t = register_type_r uis syms bbdfns [] sr t in
238: let vs t = varmap_subst hvarmap t in
239: let ts = map vs ts in
240: iter ut ts;
241: ui i1; (* this is wrong?: initialisation is not use .. *)
242: uis i2 ts;
243: (*
244: print_endline ("INSTANTIATING CLASS " ^ si i2 ^ "<"^catmap "," (sbt syms.dfns) ts^">");
245: *)
246: uis i3 ts;
247: (*
248: print_endline ("INSTANTIATING CONSTRUCTOR " ^ si i3 ^ "<"^catmap "," (sbt syms.dfns) ts^">");
249: *)
250: ue sr e2
251:
252: | `BEXE_call (sr,e1,e2)
253: | `BEXE_jump (sr,e1,e2)
254: -> ue sr e1; ue sr e2
255:
256: | `BEXE_assert (sr,e)
257: | `BEXE_loop (sr,_,e)
258: | `BEXE_ifgoto (sr,e,_)
259: | `BEXE_ifnotgoto (sr,e,_)
260: | `BEXE_fun_return (sr,e)
261: | `BEXE_yield (sr,e)
262: ->
263: ue sr e
264:
265: | `BEXE_assert2 (sr,_,e1,e2)
266: ->
267: begin match e1 with Some e -> ue sr e | None -> () end;
268: ue sr e2
269:
270: | `BEXE_init (sr,i,e) ->
271: let vs' = get_vs bbdfns i in
272: let ts = map (fun (s,i) -> `BTYP_var (i,`BTYP_type 0)) vs' in
273: let ts = map (varmap_subst hvarmap) ts in
274: uis i ts; (* this is wrong?: initialisation is not use .. *)
275: ue sr e
276:
277: | `BEXE_assign (sr,e1,e2) -> ue sr e1; ue sr e2
278:
279: | `BEXE_svc (sr,i) ->
280: let vs' = get_vs bbdfns i in
281: let ts = map (fun (s,i) -> `BTYP_var (i,`BTYP_type 0)) vs' in
282: let ts = map (varmap_subst hvarmap) ts in
283: uis i ts
284:
285: | `BEXE_label _
286: | `BEXE_halt _
287: | `BEXE_goto _
288: | `BEXE_code _
289: | `BEXE_nonreturn_code _
290: | `BEXE_comment _
291: | `BEXE_nop _
292: | `BEXE_proc_return _
293: | `BEXE_begin
294: | `BEXE_end
295: -> ()
296:
297: and process_exes syms bbdfns ref_insts1 ts hvarmap exes =
298: iter (process_exe syms bbdfns ref_insts1 ts hvarmap) exes
299:
300: and process_function syms bbdfns hvarmap ref_insts1 index sr argtypes ret exes ts =
301: (*
302: print_endline ("Process function " ^ si index);
303: *)
304: process_exes syms bbdfns ref_insts1 ts hvarmap exes ;
305: (*
306: print_endline ("Done Process function " ^ si index);
307: *)
308:
309: and process_production syms bbdfns ref_insts1 p ts =
310: let uses_symbol (_,nt) = match nt with
311: | `Nonterm ii -> iter (fun i -> add_inst syms bbdfns ref_insts1 (i,ts)) ii
312: | `Term i -> () (* HACK! This is a union constructor name we need to 'use' the union type!! *)
313: in
314: iter uses_symbol p
315:
316: and process_inst syms bbdfns instps ref_insts1 i ts inst =
317: let uis i ts = add_inst syms bbdfns ref_insts1 (i,ts) in
318: let ui i = uis i ts in
319: let id,parent,sr,entry =
320: try Hashtbl.find bbdfns i
321: with Not_found -> failwith ("[process_inst] Can't find index " ^ si i)
322: in
323: let do_reqs vs reqs =
324: iter (
325: fun (i,ts)->
326: if i = 0 then
327: clierr sr ("Entity " ^ id ^ " has uninstantiable requirements");
328: uis i( map vs ts)
329: )
330: reqs
331: in
332: let ue hvarmap e = process_expr syms bbdfns ref_insts1 hvarmap sr e in
333: let rtr t = register_type_r uis syms bbdfns [] sr t in
334: let rtnr t = register_type_nr syms (reduce_type (lstrip syms.dfns t)) in
335: if syms.compiler_options.print_flag then
336: print_endline ("//Instance "^si inst ^ "="^id^"<" ^ si i ^ ">[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]");
337: match entry with
338: | `BBDCL_glr (props,vs,ret, (p,exes)) ->
339: assert (length vs = length ts);
340: let vars = map2 (fun (s,i) t -> i,t) vs ts in
341: let hvarmap = hashtable_of_list vars in
342: process_function syms bbdfns null_table ref_insts1 i sr [] ret exes ts;
343: process_production syms bbdfns ref_insts1 p ts
344:
345: | `BBDCL_regmatch (props,vs,(ps,traint),ret,(_,_,h,_)) ->
346: let argtypes = map (fun {ptyp=t}->t) ps in
347: assert (length vs = length ts);
348: let vars = map2 (fun (s,i) t -> i,t) vs ts in
349: let hvarmap = hashtable_of_list vars in
350: Hashtbl.iter
351: (fun _ e -> ue hvarmap e)
352: h;
353: iter (fun {pindex=i} -> ui i) ps
354:
355: | `BBDCL_reglex (props,vs,(ps,traint),le,ret,(_,_,h,_)) ->
356: let argtypes = map (fun {ptyp=t}->t) ps in
357: assert (length vs = length ts);
358: let vars = map2 (fun (s,i) t -> i,t) vs ts in
359: let hvarmap = hashtable_of_list vars in
360: Hashtbl.iter
361: (fun _ e -> ue hvarmap e)
362: h;
363: iter (fun {pindex=i} -> ui i) ps;
364: ui le; (* lexeme end .. *)
365: ui i
366:
367: | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
368: let argtypes = map (fun {ptyp=t}->t) ps in
369: assert (length vs = length ts);
370: let vars = map2 (fun (s,i) t -> i,t) vs ts in
371: let hvarmap = hashtable_of_list vars in
372: if instps || mem `Cfun props then
373: iter (fun {pindex=i; ptyp=t} ->
374: ui i;
375: rtr (varmap_subst hvarmap t)
376: )
377: ps
378: ;
379: process_function syms bbdfns hvarmap ref_insts1 i sr argtypes ret exes ts
380:
381: | `BBDCL_procedure (props,vs,(ps,traint), exes) ->
382: let argtypes = map (fun {ptyp=t}->t) ps in
383: assert (length vs = length ts);
384: let vars = map2 (fun (s,i) t -> i,t) vs ts in
385: let hvarmap = hashtable_of_list vars in
386: if instps || mem `Cfun props then
387: iter (fun {pindex=i; ptyp=t} ->
388: ui i;
389: rtr (varmap_subst hvarmap t)
390: )
391: ps
392: ;
393: process_function syms bbdfns hvarmap ref_insts1 i sr argtypes `BTYP_void exes ts
394:
395: | `BBDCL_class (props,vs) ->
396: assert (length vs = length ts);
397: (*
398: let vars = map2 (fun (s,i) t -> i,t) vs ts in
399: let hvarmap = hashtable_of_list vars in
400: *)
401:
402: rtnr (`BTYP_inst (i,ts));
403:
404: (*
405: print_endline "Registering class object";
406: *)
407: ui i
408:
409: | `BBDCL_union (vs,ps) ->
410: let argtypes = map (fun (_,_,t)->t) ps in
411: assert (length vs = length ts);
412: let vars = map2 (fun (s,i) t -> i,t) vs ts in
413: let hvarmap = hashtable_of_list vars in
414: let tss = map (varmap_subst hvarmap) argtypes in
415: iter rtr tss;
416: rtnr (`BTYP_inst (i,ts))
417:
418:
419: | `BBDCL_struct (vs,ps)
420: | `BBDCL_cstruct (vs,ps)
421: ->
422: let argtypes = map snd ps in
423: assert (length vs = length ts);
424: let vars = map2 (fun (s,i) t -> i,t) vs ts in
425: let hvarmap = hashtable_of_list vars in
426: let tss = map (varmap_subst hvarmap) argtypes in
427: iter rtr tss;
428: rtnr (`BTYP_inst (i,ts))
429:
430: | `BBDCL_newtype (vs,t) ->
431: rtnr t;
432: rtnr (`BTYP_inst (i,ts))
433:
434: | `BBDCL_cclass (vs,ps)
435: ->
436: (*
437: let argtypes = map (function
438: | `BMemberVal (_,t)
439: | `BMemberVar (_,t)
440: | `BMemberFun (_,_,t)
441: | `BMemberProc (_,_,t)
442: | `BMemberCtor (_,t) -> t
443: ) ps in
444: *)
445: assert (length vs = length ts);
446: (*
447: let vars = map2 (fun (s,i) t -> i,t) vs ts in
448: let hvarmap = hashtable_of_list vars in
449: let tss = map (varmap_subst hvarmap) argtypes in
450: iter rtr tss;
451: *)
452: rtnr (`BTYP_inst (i,ts))
453:
454: | `BBDCL_val (vs,t)
455: | `BBDCL_var (vs,t)
456: | `BBDCL_ref (vs,t)
457: | `BBDCL_tmp (vs,t)
458: ->
459: (*
460: print_endline "Registering variable";
461: *)
462: if length vs <> length ts
463: then syserr sr
464: (
465: "ts/vs mismatch instantiating variable " ^ id ^ "<"^si i^">, inst "^si inst^": vs = [" ^
466: catmap ";" (fun (s,i)-> s ^"<"^si i^">") vs ^ "], " ^
467: "ts = [" ^
468: catmap ";" (fun t->sbt syms.dfns t) ts ^ "]"
469: );
470: let vars = map2 (fun (s,i) t -> i,t) vs ts in
471: let hvarmap = hashtable_of_list vars in
472: let t = varmap_subst hvarmap t in
473: rtr t
474:
475: | `BBDCL_const (vs,t,_,reqs) ->
476: (*
477: print_endline "Register const";
478: *)
479: assert (length vs = length ts);
480: (*
481: if length vs <> length ts
482: then syserr sr
483: (
484: "ts/vs mismatch index "^si i^", inst "^si inst^": vs = [" ^
485: catmap ";" (fun (s,i)-> s ^"<"^si i^">") vs ^ "], " ^
486: "ts = [" ^
487: catmap ";" (fun t->sbt syms.dfns t) ts ^ "]"
488: );
489: *)
490: assert (length vs = length ts);
491: let vars = map2 (fun (s,i) t -> i,t) vs ts in
492: let hvarmap = hashtable_of_list vars in
493: let t = varmap_subst hvarmap t in
494: rtr t;
495: let vs t = varmap_subst hvarmap t in
496: do_reqs vs reqs
497:
498: (* shortcut -- header and body can only require other header and body *)
499: | `BBDCL_insert (vs,s,ikind,reqs)
500: ->
501: (*
502: print_endline ("Handling requirements of header/body " ^ s);
503: *)
504: assert (length vs = length ts);
505: let vars = map2 (fun (s,i) t -> i,t) vs ts in
506: let hvarmap = hashtable_of_list vars in
507: let vs t = varmap_subst hvarmap t in
508: do_reqs vs reqs
509:
510:
511: | `BBDCL_fun (props,vs,argtypes,ret,_,reqs,_) ->
512: (*
513: print_endline ("Handling requirements of fun " ^ id);
514: *)
515: if length vs <> length ts then
516: print_endline ("For fun " ^ id ^ " vs=" ^ print_bvs vs ^
517: ", but ts=" ^ catmap "," (sbt syms.dfns) ts)
518: ;
519: assert (length vs = length ts);
520: let vars = map2 (fun (s,i) t -> i,t) vs ts in
521: let hvarmap = hashtable_of_list vars in
522: let vs t = varmap_subst hvarmap t in
523: do_reqs vs reqs;
524: process_function syms bbdfns hvarmap ref_insts1 i sr argtypes ret [] ts
525:
526: | `BBDCL_callback (props,vs,argtypes_cf,argtypes_c,k,ret,reqs,_) ->
527: (*
528: print_endline ("Handling requirements of callback " ^ id);
529: *)
530: assert (length vs = length ts);
531: let vars = map2 (fun (s,i) t -> i,t) vs ts in
532: let hvarmap = hashtable_of_list vars in
533: let vs t = varmap_subst hvarmap t in
534: do_reqs vs reqs;
535:
536: let ret = varmap_subst hvarmap ret in
537: rtr ret;
538:
539: (* prolly not necessary .. *)
540: let tss = map (varmap_subst hvarmap) argtypes_cf in
541: iter rtr tss;
542:
543: (* just to register 'address' .. lol *)
544: let tss = map (varmap_subst hvarmap) argtypes_c in
545: iter rtr tss
546:
547: | `BBDCL_proc (props,vs,argtypes,_,reqs) ->
548: (*
549: print_endline ("[flx_inst] Handling requirements of proc " ^ id);
550: print_endline ("vs = " ^ catmap "," (fun (s,i) -> s ^ "<" ^ si i ^ ">") vs);
551: print_endline ("ts = " ^ catmap "," (sbt syms.dfns) ts);
552: *)
553: assert (length vs = length ts);
554: let vars = map2 (fun (s,i) t -> i,t) vs ts in
555: let hvarmap = hashtable_of_list vars in
556: let vs t = varmap_subst hvarmap t in
557: do_reqs vs reqs;
558: process_function syms bbdfns hvarmap ref_insts1 i sr argtypes `BTYP_void [] ts
559:
560: | `BBDCL_abs (vs,_,_,reqs)
561: ->
562: assert (length vs = length ts);
563: let vars = map2 (fun (s,i) t -> i,t) vs ts in
564: let hvarmap = hashtable_of_list vars in
565: let vs t = varmap_subst hvarmap t in
566: do_reqs vs reqs
567:
568: | `BBDCL_nonconst_ctor (vs,uidx,udt, ctor_idx, ctor_argt, evs, etraint) ->
569: assert (length vs = length ts);
570: let vars = map2 (fun (s,i) t -> i,t) vs ts in
571: let hvarmap = hashtable_of_list vars in
572:
573: (* we don't register the union .. it's a uctor anyhow *)
574: let ctor_argt = varmap_subst hvarmap ctor_argt in
575: rtr ctor_argt
576:
577: | `BBDCL_typeclass _ -> ()
578: | `BBDCL_instance (props,vs,con,tc,ts) -> ()
579:
580: (*
581: This routine creates the instance tables.
582: There are 2 tables: instance types and function types (including procs)
583:
584: The type registry holds the types used.
585: The instance registry holds a pair:
586: (index, types)
587: where index is the function or procedure index,
588: and types is a list of types to instantiated it.
589:
590: The algorithm starts with a list of roots, being
591: the top level init routine and any exported functions.
592: These must be non-generic.
593:
594: It puts these into a set of functions to be examined.
595: Then it begins examining the set by chosing one function
596: and moving it to the 'examined' set.
597:
598: It registers the function type, and then
599: examines the body.
600:
601: In the process of examining the body,
602: every function or procedure call is examined.
603:
604: The function being called is added to the
605: to be examined list with the calling type arguments.
606: Note that these type arguments may include type variables
607: which have to be replaced by their instances which are
608: passed to the examination routine.
609:
610: The process continues until there are no unexamined
611: functions left. The effect is to instantiate every used
612: type and function.
613: *)
614:
615: let instantiate syms bbdfns instps (root:bid_t) (bifaces:biface_t list) =
616: Hashtbl.clear syms.instances;
617: Hashtbl.clear syms.registry;
618:
619: (* empty instantiation registry *)
620: let insts1 = ref FunInstSet.empty in
621:
622: begin
623: (* append routine to add an instance *)
624: let add_cand i ts = insts1 := FunInstSet.add (i,ts) !insts1 in
625:
626: (* add the root *)
627: add_cand root [];
628:
629: (* add exported functions, and register exported types *)
630: let ui i ts = add_inst syms bbdfns insts1 (i,ts) in
631: iter
632: (function
633: | `BIFACE_export_fun (_,x,_) ->
634: let _,_,sr,entry = Hashtbl.find bbdfns x in
635: begin match entry with
636: | `BBDCL_procedure (props,_,(ps,_),_)
637: | `BBDCL_function (props,_,(ps,_),_,_) ->
638: begin match ps with
639: | [] -> ()
640: | [{ptyp=t}] -> register_type_r ui syms bbdfns [] sr t
641: | _ ->
642: let t =
643: `BTYP_tuple
644: (
645: map
646: (fun {ptyp=t} -> t)
647: ps
648: )
649: in
650: register_type_r ui syms bbdfns [] sr t;
651: register_type_nr syms t;
652: end
653: | _ -> assert false
654: end
655: ;
656: add_cand x []
657:
658: | `BIFACE_export_type (sr,t,_) ->
659: register_type_r ui syms bbdfns [] sr t
660: )
661: bifaces
662: end
663: ;
664:
665: (* NEW: if a symbol is monomorphic use its index as its instance! *)
666: (* this is a TRICK .. saves remapping the root/exports, since they
667: have to be monomorphic anyhow
668: *)
669: let add_instance i ts =
670: let n =
671: match ts with
672: | [] -> i
673: | _ -> let n = !(syms.counter) in incr (syms.counter); n
674: in
675: Hashtbl.add syms.instances (i,ts) n;
676: n
677: in
678:
679: while not (FunInstSet.is_empty !insts1) do
680: let (index,vars) as x = FunInstSet.choose !insts1 in
681: insts1 := FunInstSet.remove x !insts1;
682: let inst = add_instance index vars in
683: process_inst syms bbdfns instps insts1 index vars inst
684: done
685:
686:
687: (* BUG!!!!! Abstract type requirements aren't handled!! *)
688: