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