1: # 19 "./lpsrc/flx_mono.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_print
6: open Flx_mtypes1
7: open Flx_mtypes2
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_generic
15: open Flx_maps
16: open Flx_exceptions
17: open Flx_use
18: open Flx_child
19: open Flx_reparent
20: open Flx_spexes
21: open Flx_beta
22: open Flx_prop
23:
24: let cal_parent syms bbdfns i' ts' =
25: let id,parent,sr,_ = Hashtbl.find bbdfns i' in
26: match parent with
27: | None -> None
28: | Some i ->
29: let vsc = get_vs bbdfns i' in
30: assert (length vsc = length ts');
31: if not (Hashtbl.mem bbdfns i) then None else
32: let vsp = get_vs bbdfns i in
33: let n = length vsp in
34: assert (n <= length vsc);
35: let ts = list_prefix ts' n in
36: let k =
37: try (Hashtbl.find syms.instances (i,ts))
38: with Not_found ->
39: print_endline ("Wah? Not found parent of " ^
40: id ^ "<" ^ si i' ^ ">" ^
41: "[" ^ catmap "," (sbt syms.dfns) ts ^ "]\n" ^
42: "Which should be " ^ si i ^
43: "[" ^ catmap "," (sbt syms.dfns) ts ^ "]"
44: )
45: ;
46: assert false
47: in
48: if ts = [] then assert (i=k);
49: (*
50: print_endline ("Parent of " ^ si i' ^ " was " ^ si i ^ " is now " ^ si k);
51: *)
52: Some k
53:
54: let fixup_type' syms bbdfns fi t =
55: match t with
56: | `BTYP_inst (i,ts) ->
57: let i,ts = fi i ts in
58: `BTYP_inst (i,ts)
59: | x -> x
60:
61: let rec fixup_type syms bbdfns fi t =
62: let ft t = fixup_type syms bbdfns fi t in
63: let ft' t = fixup_type' syms bbdfns fi t in
64: let t = map_btype ft t in
65: ft' t
66:
67: let fixup_expr' syms bbdfns fi mt (e:bexpr_t) =
68: (*
69: print_endline ("FIXUP EXPR(up) " ^ sbe syms.dfns (e,`BTYP_void));
70: *)
71: let x = match e with
72: | `BEXPR_apply_prim (i',ts,a) ->
73: let i,ts = fi i' ts in
74: if i = i' then
75: `BEXPR_apply_prim (i,ts,a)
76: else
77: `BEXPR_apply_direct (i,ts,a)
78:
79: | `BEXPR_apply_direct (i,ts,a) ->
80: let i,ts = fi i ts in
81: `BEXPR_apply_direct (i,ts,a)
82:
83: | `BEXPR_apply_struct (i,ts,a) ->
84: let i,ts = fi i ts in
85: `BEXPR_apply_struct (i,ts,a)
86:
87: | `BEXPR_apply_stack (i,ts,a) ->
88: let i,ts = fi i ts in
89: `BEXPR_apply_stack (i,ts,a)
90:
91: | `BEXPR_apply_method_direct (obj,i,ts,a) ->
92: let i,ts = fi i ts in
93: `BEXPR_apply_method_direct (obj,i,ts,a)
94:
95: | `BEXPR_apply_method_stack (obj,i,ts,a) ->
96: let i,ts = fi i ts in
97: `BEXPR_apply_method_stack (obj,i,ts,a)
98:
99: | `BEXPR_ref (i,ts) ->
100: let i,ts = fi i ts in
101: `BEXPR_ref (i,ts)
102:
103: | `BEXPR_name (i',ts') ->
104: let i,ts = fi i' ts' in
105: (*
106: print_endline (
107: "Ref to Variable " ^ si i' ^ "[" ^ catmap "," (sbt syms.dfns) ts' ^"]" ^
108: " mapped to " ^ si i ^ "[" ^ catmap "," (sbt syms.dfns) ts ^"]"
109: );
110: *)
111: `BEXPR_name (i,ts)
112:
113: | `BEXPR_closure (i,ts) ->
114: let i,ts = fi i ts in
115: `BEXPR_closure (i,ts)
116:
117: | `BEXPR_method_closure (e,i,ts) ->
118: let i,ts = fi i ts in
119: `BEXPR_method_closure (e,i,ts)
120: | x -> x
121: in
122: (*
123: print_endline ("FIXed UP EXPR " ^ sbe syms.dfns (x,`BTYP_void));
124: *)
125: x
126:
127: let id x = x
128:
129: let rec fixup_expr syms bbdfns fi mt e =
130: (*
131: print_endline ("FIXUP EXPR(down) " ^ sbe syms.dfns e);
132: *)
133: let fe e = fixup_expr syms bbdfns fi mt e in
134: let fe' (e,t) = fixup_expr' syms bbdfns fi mt e,t in
135: (* this is deviant case: implied ts is vs of parent!,
136: it has to be done FIRST before the type is remapped
137: *)
138: let e = match e with
139: | `BEXPR_get_named (i,(e,t)),t' ->
140: (*
141: print_endline ("REMAPPING component variable " ^ si i);
142: *)
143: let vs = get_vs bbdfns i in
144: (*
145: print_endline ("vs = " ^ catmap "," (fun (s,i) -> s ^ "<" ^ si i ^ ">") vs);
146: *)
147: begin match t with
148: | `BTYP_inst (j,ts)
149: | `BTYP_lvalue (`BTYP_inst (j,ts)) ->
150: (*
151: print_endline ("type=" ^ si j ^ ", ts = " ^ catmap "," (sbt syms.dfns) ts);
152: *)
153: let i,ts = fi i ts in
154: (*
155: print_endline ("Remapped to " ^ si i);
156: *)
157: `BEXPR_get_named (i,(e,t)),t'
158: | _ -> assert false
159: end
160: | x -> x
161: in
162: let e = map_tbexpr id fe mt e in
163: fe' e
164:
165: let fixup_exe syms bbdfns fi mt exe =
166: (*
167: print_endline ("FIXUP EXE[In] =" ^ string_of_bexe syms.dfns 0 exe);
168: *)
169: let fe e = fixup_expr syms bbdfns fi mt e in
170: let result =
171: match map_bexe id fe mt id id exe with
172: | `BEXE_call_direct (sr, i,ts,a) -> assert false
173: (*
174: let i,ts = fi i ts in
175: `BEXE_call_direct (sr,i,ts,a)
176: *)
177:
178: | `BEXE_jump_direct (sr, i,ts,a) -> assert false
179: (*
180: let i,ts = fi i ts in
181: `BEXE_jump_direct (sr,i,ts,a)
182: *)
183:
184: | `BEXE_call_prim (sr, i',ts,a) -> assert false
185: (*
186: let i,ts = fi i' ts in
187: if i = i' then
188: `BEXE_call_prim (sr,i,ts,a)
189: else
190: `BEXE_call_direct (sr,i,ts,a)
191: *)
192:
193: | `BEXE_call_stack (sr, i,ts,a) -> assert false
194: (*
195: let i,ts = fi i ts in
196: `BEXE_call_stack (sr,i,ts,a)
197: *)
198:
199: | `BEXE_call_method_direct (sr,o,i,ts,a) ->
200: let i,ts = fi i ts in
201: `BEXE_call_method_direct (sr,o, i,ts,a)
202:
203: | `BEXE_call_method_stack (sr, o, i,ts,a) ->
204: let i,ts = fi i ts in
205: `BEXE_call_method_stack (sr,o, i,ts,a)
206:
207: (* this is deviant case: implied ts is vs of parent! *)
208: | `BEXE_init (sr,i,e) ->
209: (*
210: print_endline ("[init] Deviant case variable " ^ si i);
211: *)
212: let vs = get_vs bbdfns i in
213: let ts = map (fun (s,j) -> mt (`BTYP_var (j,`BTYP_type 0))) vs in
214: let i,ts = fi i ts in
215: (*
216: print_endline ("[init] Remapped deviant variable to " ^ si i);
217: *)
218: `BEXE_init (sr,i,e)
219:
220: | `BEXE_svc (sr,i) ->
221: (*
222: print_endline ("[svc] Deviant case variable " ^ si i);
223: *)
224: let vs = get_vs bbdfns i in
225: let ts = map (fun (s,j) -> mt (`BTYP_var (j,`BTYP_type 0))) vs in
226: let i,ts = fi i ts in
227: (*
228: print_endline ("[svc] Remapped deviant variable to " ^ si i);
229: *)
230: `BEXE_svc (sr,i)
231:
232:
233: | `BEXE_apply_ctor (sr,dst,cls,clsts,ctor,ctorarg) ->
234: (*
235: print_endline ("ORIGINAL: apply ctor " ^ si ctor ^ " class " ^ si cls ^ " ts = " ^ catmap "," (sbt syms.dfns) clsts);
236: *)
237: let cls,clsts = fi cls clsts and ctor,_ = fi ctor clsts in
238: (*
239: print_endline ("REMAPPED: apply ctor " ^ si ctor ^ " class " ^ si cls ^ " ts = " ^ catmap "," (sbt syms.dfns) clsts);
240: *)
241: let dstvs = get_vs bbdfns dst in
242: let dstts = map (fun (s,j) -> mt (`BTYP_var (j,`BTYP_type 0))) dstvs in
243: let dst,dstts = fi dst dstts in
244: `BEXE_apply_ctor (sr,dst,cls,clsts,ctor,ctorarg)
245:
246: | `BEXE_apply_ctor_stack (sr,dst,cls,clsts,ctor,ctorarg) ->
247: (*
248: print_endline ("ORIGINAL: apply ctor " ^ si ctor ^ " class " ^ si cls ^ " ts = " ^ catmap "," (sbt syms.dfns) clsts);
249: *)
250: let cls,clsts = fi cls clsts and ctor,_ = fi ctor clsts in
251: (*
252: print_endline ("REMAPPED: apply ctor " ^ si ctor ^ " class " ^ si cls ^ " ts = " ^ catmap "," (sbt syms.dfns) clsts);
253: *)
254: let dstvs = get_vs bbdfns dst in
255: let dstts = map (fun (s,j) -> mt (`BTYP_var (j,`BTYP_type 0))) dstvs in
256: let dst,dstts = fi dst dstts in
257: `BEXE_apply_ctor_stack (sr,dst,cls,clsts,ctor,ctorarg)
258:
259:
260: | x -> x
261: in
262: (*
263: print_endline ("FIXUP EXE[Out]=" ^ string_of_bexe syms.dfns 0 result);
264: *)
265: result
266:
267:
268: let fixup_exes syms bbdfns fi mt exes =
269: map (fixup_exe syms bbdfns fi mt) exes
270:
271: let mono syms (bbdfns: fully_bound_symbol_table_t) fi i ts n =
272: let id,parent,sr,entry = Hashtbl.find bbdfns i in
273: match entry with
274:
275: | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
276: let props = filter (fun p -> p <> `Virtual) props in
277: let vars = map2 (fun (s,i) t -> i,t) vs ts in
278: let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
279: let ret = mt ret in
280: (*
281: let fi i ts = fi i (map mt ts) in
282: *)
283: let ps = map (fun {pkind=pk; pid=s;pindex=i; ptyp=t} ->
284: {pkind=pk;pid=s;pindex=fst (fi i ts);ptyp=mt t}) ps
285: in
286: let traint = match traint with | None -> None | Some x -> Some (fixup_expr syms bbdfns fi mt x) in
287: let exes = fixup_exes syms bbdfns fi mt exes in
288: let entry = `BBDCL_function (props,[],(ps,traint),ret,exes) in
289: let parent = cal_parent syms bbdfns i ts in
290: Hashtbl.replace bbdfns n (id,parent,sr,entry)
291:
292: | `BBDCL_procedure (props,vs,(ps,traint), exes) ->
293: let props = filter (fun p -> p <> `Virtual) props in
294: let vars = map2 (fun (s,i) t -> i,t) vs ts in
295: let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
296: let ps = map (fun {pkind=pk; pid=s;pindex=i; ptyp=t} ->
297: let k = fst (fi i ts) in
298: let u = mt t in
299: (*
300: print_endline ("Remap parameter " ^ s ^"<"^ si i ^ "> (type " ^
301: sbt syms.dfns t ^
302: ")to " ^ si k ^ " type " ^ sbt syms.dfns u);
303: *)
304: {pkind=pk;pid=s;pindex=k;ptyp=u}) ps
305: in
306: let traint = match traint with | None -> None | Some x -> Some (fixup_expr syms bbdfns fi mt x) in
307: (*
308: let fi i ts = fi i (map mt ts) in
309: *)
310: let exes = fixup_exes syms bbdfns fi mt exes in
311: let entry = `BBDCL_procedure (props,[],(ps,traint), exes) in
312: let parent = cal_parent syms bbdfns i ts in
313: Hashtbl.replace bbdfns n (id,parent,sr,entry)
314:
315: | `BBDCL_val (vs,t) ->
316: let vars = map2 (fun (s,i) t -> i,t) vs ts in
317: let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
318: let t = mt t in
319: let entry = `BBDCL_val ([],t) in
320: let parent = cal_parent syms bbdfns i ts in
321: Hashtbl.replace bbdfns n (id,parent,sr,entry)
322:
323: | `BBDCL_var (vs,t) ->
324: let vars = map2 (fun (s,i) t -> i,t) vs ts in
325: let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
326: let t = mt t in
327: let entry = `BBDCL_var ([],t) in
328: let parent = cal_parent syms bbdfns i ts in
329: Hashtbl.replace bbdfns n (id,parent,sr,entry)
330:
331: | `BBDCL_ref (vs,t) ->
332: let vars = map2 (fun (s,i) t -> i,t) vs ts in
333: let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
334: let t = mt t in
335: let entry = `BBDCL_ref ([],t) in
336: let parent = cal_parent syms bbdfns i ts in
337: Hashtbl.replace bbdfns n (id,parent,sr,entry)
338:
339: | `BBDCL_tmp (vs,t) ->
340: let vars = map2 (fun (s,i) t -> i,t) vs ts in
341: let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
342: let t = mt t in
343: let entry = `BBDCL_tmp ([],t) in
344: let parent = cal_parent syms bbdfns i ts in
345: Hashtbl.replace bbdfns n (id,parent,sr,entry)
346:
347: | `BBDCL_class (props,vs) ->
348: let vars = map2 (fun (s,i) t -> i,t) vs ts in
349: let entry = `BBDCL_class (props,[]) in
350: let parent = cal_parent syms bbdfns i ts in
351: Hashtbl.replace bbdfns n (id,parent,sr,entry)
352:
353: (* we have tp replace types in interfaces like Vector[int]
354: with monomorphic versions if any .. even if we don't
355: monomorphise the entry itself.
356:
357: This is weak .. it's redone for each instance, relies
358: on mt being idempotent..
359: *)
360: | `BBDCL_fun (props,vs,argtypes,ret,ct,reqs,prec) ->
361: let vars = map2 (fun (s,i) t -> i,t) vs ts in
362: let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
363: let argtypes = map mt argtypes in
364: let ret = mt ret in
365: let entry = `BBDCL_fun (props,vs,argtypes,ret,ct,reqs,prec) in
366: Hashtbl.replace bbdfns i (id,parent, sr, entry)
367:
368:
369: | `BBDCL_proc (props,vs,argtypes,ct,reqs) ->
370: let vars = map2 (fun (s,i) t -> i,t) vs ts in
371: let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
372: let argtypes = map mt argtypes in
373: let entry = `BBDCL_proc (props,vs,argtypes,ct,reqs) in
374: Hashtbl.replace bbdfns i (id,parent, sr, entry)
375:
376: | `BBDCL_const (vs,t,`Str "#this",reqs) ->
377: let vars = map2 (fun (s,i) t -> i,t) vs ts in
378: let mt t = reduce_type (beta_reduce syms sr (fixup_type syms bbdfns fi (list_subst vars t))) in
379: let t = mt t in
380: let entry = `BBDCL_const([],t,`Str "#this",reqs) in
381: let parent = cal_parent syms bbdfns i ts in
382: Hashtbl.replace bbdfns n (id,parent,sr,entry)
383:
384: | `BBDCL_regmatch (props,vs,(ps,traint),ret,(alpha,states,h,mx)) ->
385: let vars = map2 (fun (s,i) t -> i,t) vs ts in
386: let mt t = list_subst vars t in
387: let traint = match traint with | None -> None | Some x -> Some (fixup_expr syms bbdfns fi mt x) in
388: let ps = map (fun {pkind=pk; pid=s;pindex=i; ptyp=t} ->
389: {pkind=pk;pid=s;pindex=fst (fi i ts);ptyp=mt t}) ps
390: in
391: let ret = mt ret in
392: let h2 = Hashtbl.create 97 in
393: Hashtbl.iter (fun j e ->
394: let e = fixup_expr syms bbdfns fi mt e in
395: Hashtbl.add h2 j e
396: )
397: h
398: ;
399: let entry = `BBDCL_regmatch (props,[],(ps,traint),ret,(alpha,states,h2,mx)) in
400: let parent = cal_parent syms bbdfns i ts in
401: Hashtbl.replace bbdfns n (id,parent,sr,entry)
402:
403:
404: (*
405: | `BBDCL_glr (props,vs,ret, (p,exes)) ->
406: let vars = map2 (fun (s,i) t -> i,t) vs ts in
407: let mt t = list_subst vars t in
408: let ret = mt ret in
409: let exes = fixup_exes syms bbdfns mt exes in
410: `BBDCL_glr (props,[],ret,(p,exes))
411:
412: | `BBDCL_reglex (props,vs,(ps,traint),le,ret,(alpha,states,h,mx)) ->
413: let vars = map2 (fun (s,i) t -> i,t) vs ts in
414: let mt t = list_subst vars t in
415: let traint = match traint with | None -> None | Some x -> Some (fixup_expr syms bbdfns mt x) in
416: let ret = mt ret in
417: `BBDCL_reglex (props,[],(ps,traint),le,ret,(alpha,states,h,mx))
418:
419: | `BBDCL_union (vs,ps) ->
420: let vars = map2 (fun (s,i) t -> i,t) vs ts in
421: let mt t = list_subst vars t in
422: let ps = map (fun (i,j,t) -> i,j,mt t) ps in
423: `BBDCL_union ([],ps)
424:
425: | `BBDCL_struct (vs,ps) ->
426: let vars = map2 (fun (s,i) t -> i,t) vs ts in
427: let mt t = list_subst vars t in
428: let ps = map (fun (i,t) -> i,mt t) ps in
429: `BBDCL_struct ([],ps)
430:
431: | `BBDCL_cstruct (vs,ps) ->
432: let vars = map2 (fun (s,i) t -> i,t) vs ts in
433: let mt t = list_subst vars t in
434: let ps = map (fun (i,t) -> i,mt t) ps in
435: `BBDCL_cstruct ([],ps)
436:
437: | `BBDCL_newtype (vs,t) ->
438: let vars = map2 (fun (s,i) t -> i,t) vs ts in
439: let mt t = list_subst vars t in
440: let t = mt t in
441: `BBDCL_newtype ([],t)
442:
443: | `BBDCL_cclass (vs,ps) ->
444: let vars = map2 (fun (s,i) t -> i,t) vs ts in
445: `BBDCL_cclass ([],ps)
446:
447: | `BBDCL_const (vs,t,ct,reqs) ->
448: let vars = map2 (fun (s,i) t -> i,t) vs ts in
449: `BBDCL_const ([],t,ct,reqs)
450:
451: | `BBDCL_insert (vs,s,ikind,reqs) ->
452: let vars = map2 (fun (s,i) t -> i,t) vs ts in
453: `BBDCL_insert ([],s,ikind,reqs)
454:
455:
456: | `BBDCL_callback (props,vs,argtypes_cf,argtypes_c,k,ret,reqs,prec) ->
457: let vars = map2 (fun (s,i) t -> i,t) vs ts in
458: `BBDCL_callback (props,[],argtypes_cf,argtypes_c,k,ret,reqs,prec)
459:
460: | `BBDCL_abs (vs,tqual,ct,reqs) ->
461: let vars = map2 (fun (s,i) t -> i,t) vs ts in
462: `BBDCL_abs ([],tqual,ct,reqs)
463:
464: | `BBDCL_nonconst_ctor (vs,uidx,udt, ctor_idx, ctor_argt, evs, etraint) ->
465: let vars = map2 (fun (s,i) t -> i,t) vs ts in
466: `BBDCL_nonconst_ctor ([],uidx,udt, ctor_idx, ctor_argt, evs, etraint)
467:
468: | `BBDCL_typeclass (props,vs) -> entry
469: (*
470: let vars = map2 (fun (s,i) t -> i,t) vs ts in
471: `BBDCL_typeclass (props,[])
472: *)
473:
474: | `BBDCL_instance (props,vs,con,tc,ts) -> entry
475: (*
476: let vars = map2 (fun (s,i) t -> i,t) vs ts in
477: `BBDCL_instance (props,[],con,tc,ts) ->
478: *)
479: *)
480:
481: | _ -> ()
482:
483: let chk_mono syms (bbdfns: fully_bound_symbol_table_t) i =
484: let id,parent,sr,entry = Hashtbl.find bbdfns i in
485: match entry with
486: | `BBDCL_function (props,vs,(ps,traint),ret,exes) -> true
487: | `BBDCL_procedure (props,vs,(ps,traint), exes) -> true
488: | `BBDCL_val (vs,t) -> true
489: | `BBDCL_var (vs,t) -> true
490: | `BBDCL_ref (vs,t) -> true
491: | `BBDCL_tmp (vs,t) -> true
492: | `BBDCL_class (props,vs) -> true
493: | `BBDCL_const (_,_,`Str "#this",_) -> true
494: | `BBDCL_regmatch (props,vs,(ps,traint),ret,(alpha,states,h,mx)) -> true
495:
496:
497: | `BBDCL_glr (props,vs,ret, (p,exes)) -> false
498: | `BBDCL_reglex (props,vs,(ps,traint),le,ret,(alpha,states,h,mx)) -> false
499: | `BBDCL_union (vs,ps) -> false
500: | `BBDCL_struct (vs,ps) -> false
501: | `BBDCL_cstruct (vs,ps) -> false
502: | `BBDCL_newtype (vs,t) -> false
503: | `BBDCL_cclass (vs,ps) -> false
504: | `BBDCL_const (vs,t,ct,reqs) -> false
505: | `BBDCL_insert (vs,s,ikind,reqs) -> false
506: | `BBDCL_fun (props,vs,argtypes,ret,ct,reqs,prec) -> false
507: | `BBDCL_callback (props,vs,argtypes_cf,argtypes_c,k,ret,reqs,prec) -> false
508: | `BBDCL_proc (props,vs,argtypes,ct,reqs) -> false
509: | `BBDCL_abs (vs,tqual,ct,reqs) -> false
510: | `BBDCL_nonconst_ctor (vs,uidx,udt, ctor_idx, ctor_argt, evs, etraint) -> false
511: | `BBDCL_typeclass (props,vs) -> false
512: | `BBDCL_instance (props,vs,con,tc,ts) -> false
513:
514: (* monomorphic instances are already equal to their indices ..
515: replace some polymorphic instances with monomorphic ones
516: *)
517: let monomorphise syms bbdfns =
518: let polyinst = Hashtbl.create 97 in
519: Hashtbl.iter
520: (fun (i,ts) n ->
521: if ts = [] then assert (i = n )
522: else
523: if chk_mono syms bbdfns i
524: then begin
525: (*
526: print_endline ("polyinst " ^ si n ^ " = " ^
527: si i ^ "["^catmap "," (sbt syms.dfns) ts^"]");
528: *)
529: Hashtbl.add polyinst (i,ts) n
530: end else begin
531: (*
532: print_endline ("*** NO polyinst " ^ si n ^ " = " ^
533: si i ^ "["^catmap "," (sbt syms.dfns) ts^"]");
534: *)
535: end
536:
537: )
538: syms.instances
539: ;
540:
541: let fi polyinst i ts =
542: let ts = map reduce_type ts in
543: let i,ts = Flx_typeclass.maybe_fixup_typeclass_instance syms bbdfns i ts in
544: try Hashtbl.find polyinst (i,ts),[]
545: with Not_found -> i,ts
546: in
547:
548: (* make a new table where the ts are ALSO converted to monomorphised
549: class clones .. we still need the originals for non-type uses
550: of the class (eg constructor)
551: *)
552: let polyinst2 = Hashtbl.create 97 in
553: Hashtbl.iter
554: (fun (i,ts) n ->
555: Hashtbl.replace polyinst2 (i,ts) n;
556: let ts = map (fixup_type syms bbdfns (fi polyinst)) ts in
557: Hashtbl.replace polyinst2 (i,ts) n;
558: )
559: polyinst
560: ;
561: let fi i ts = fi polyinst2 i ts in
562:
563: Hashtbl.iter
564: (fun (i,ts) n ->
565: if syms.compiler_options.print_flag then begin
566: if (n <> i) then print_endline (
567: "[monomorphise] Adding instance " ^ si n ^ " = " ^
568: si i ^ "["^catmap "," (sbt syms.dfns) ts^"]"
569: ) else print_endline (
570: "[monomorphise] Process instance " ^ si n ^ " = " ^
571: si i ^ "["^catmap "," (sbt syms.dfns) ts^"]"
572: );
573: end;
574:
575:
576: mono syms bbdfns fi i ts n;
577: )
578: syms.instances
579: ;
580:
581: Hashtbl.iter (fun (i,ts) n ->
582: Hashtbl.remove syms.instances (i,ts);
583: Hashtbl.add syms.instances (n,[]) n;
584: )
585: polyinst
586: ;
587: