1: # 65 "./lpsrc/flx_reparent.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:
20: module BidSet = IntSet
21:
22: let mk_remap counter d =
23: let m = Hashtbl.create 97 in
24: IntSet.iter
25: (fun i ->
26: let n = !counter in
27: incr counter;
28: Hashtbl.add m i n
29: )
30: d
31: ;
32: m
33:
34: (* replace callee type variables with callers *)
35: let vsplice caller_vars callee_vs_len ts =
36: if not (callee_vs_len <= length ts)
37: then failwith
38: (
39: "Callee_vs_len = " ^
40: si callee_vs_len ^
41: ", len vs/ts= " ^
42: si (length ts) ^
43: ", length caller_vars = " ^
44: si (length caller_vars)
45: )
46: ;
47: let rec aux lst n = (* elide first n elements *)
48: if n = 0 then lst
49: else aux (tl lst) (n-1)
50: in
51: caller_vars @ aux ts callee_vs_len
52:
53:
54: (* varmap is the *typevariable* remapper,
55: revariable remaps indices
56: *)
57: let ident x = x
58:
59: let remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e =
60: (*
61: print_endline ("Remapping expression " ^ sbe syms.dfns e);
62: *)
63: let ftc i ts = Flx_typeclass.maybe_fixup_typeclass_instance syms bbdfns i ts in
64: let revar i = try Hashtbl.find revariable i with Not_found -> i in
65: let tmap t = match t with
66: | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
67: | x -> x
68: in
69: let auxt t =
70: map_btype tmap (varmap_subst varmap t)
71: in
72: let fixup i ts =
73: let ts = map auxt ts in
74: try
75: let j= Hashtbl.find revariable i in
76: j, vsplice caller_vars callee_vs_len ts
77: with Not_found -> i,ts
78: in
79: let rec aux e = match map_tbexpr ident aux auxt e with
80: | `BEXPR_name (i,ts),t ->
81: let i,ts = fixup i ts in
82: `BEXPR_name (i,ts), auxt t
83:
84: | `BEXPR_ref (i,ts) as x,t ->
85: let i,ts = fixup i ts in
86: `BEXPR_ref (i,ts), auxt t
87:
88: | `BEXPR_closure (i,ts),t ->
89: let i,ts = fixup i ts in
90: `BEXPR_closure (i,ts), auxt t
91:
92: | `BEXPR_method_closure (obj,i,ts),t ->
93: let i,ts = fixup i ts in
94: `BEXPR_method_closure (aux obj,i,ts), auxt t
95:
96: | `BEXPR_apply_direct (i,ts,e),t ->
97: let i,ts = fixup i ts in
98:
99: (* attempt to fixup typeclass virtual *)
100: let i,ts = ftc i ts in
101: `BEXPR_apply_direct (i,ts,aux e), auxt t
102:
103: | `BEXPR_apply_method_direct (obj,i,ts,e),t ->
104: let i,ts = fixup i ts in
105: `BEXPR_apply_method_direct (aux obj,i,ts,aux e), auxt t
106:
107: | `BEXPR_apply_stack (i,ts,e),t ->
108: let i,ts = fixup i ts in
109: `BEXPR_apply_stack (i,ts,aux e), auxt t
110:
111: | `BEXPR_apply_method_stack (obj,i,ts,e),t ->
112: let i,ts = fixup i ts in
113: `BEXPR_apply_method_stack (aux obj,i,ts,aux e), auxt t
114:
115: | `BEXPR_apply_prim (i,ts,e),t ->
116: let i,ts = fixup i ts in
117: `BEXPR_apply_prim (i,ts,aux e), auxt t
118:
119: | `BEXPR_parse (e,gs),t ->
120: let e = aux e in
121: let gs = map revar gs in
122: `BEXPR_parse (e,gs), auxt t
123:
124: | x -> x
125: in
126: let a = aux e in
127: (*
128: print_endline ("replace " ^ sbe syms.dfns e ^ "-->" ^ sbe syms.dfns a);
129: *)
130: a
131:
132: let remap_exe syms bbdfns relabel varmap revariable caller_vars callee_vs_len exe =
133: (*
134: print_endline ("remap_exe " ^ string_of_bexe syms.dfns 0 exe);
135: *)
136: let ge e = remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e in
137: let revar i = try Hashtbl.find revariable i with Not_found -> i in
138: let relab s = try Hashtbl.find relabel s with Not_found -> s in
139: let ftc i ts = Flx_typeclass.maybe_fixup_typeclass_instance syms bbdfns i ts in
140:
141: let tmap t = match t with
142: | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
143: | x -> x
144: in
145: let auxt t =
146: map_btype tmap (varmap_subst varmap t)
147: in
148: let exe =
149: match exe with
150: | `BEXE_axiom_check _ -> assert false
151: | `BEXE_call_prim (sr,i,ts,e2) -> assert false
152: (*
153: let fixup i ts =
154: let ts = map auxt ts in
155: try
156: let j= Hashtbl.find revariable i in
157: j, vsplice caller_vars callee_vs_len ts
158: with Not_found -> i,ts
159: in
160: let i,ts = fixup i ts in
161: `BEXE_call_prim (sr,i,ts, ge e2)
162: *)
163:
164: | `BEXE_call_direct (sr,i,ts,e2) -> assert false
165: (*
166: let fixup i ts =
167: let ts = map auxt ts in
168: try
169: let j= Hashtbl.find revariable i in
170: j, vsplice caller_vars callee_vs_len ts
171: with Not_found -> i,ts
172: in
173: let i,ts = fixup i ts in
174:
175: (* attempt to instantiate typeclass virtual *)
176: let i,ts = ftc i ts in
177: `BEXE_call_direct (sr,i,ts, ge e2)
178: *)
179:
180: | `BEXE_call_method_direct (sr,e1,i,ts,e2) ->
181: let fixup i ts =
182: let ts = map auxt ts in
183: try
184: let j= Hashtbl.find revariable i in
185: j, vsplice caller_vars callee_vs_len ts
186: with Not_found -> i,ts
187: in
188: let i,ts = fixup i ts in
189: `BEXE_call_method_direct (sr,ge e1,i,ts, ge e2)
190:
191: | `BEXE_call_method_stack (sr,e1,i,ts,e2) ->
192: let fixup i ts =
193: let ts = map auxt ts in
194: try
195: let j= Hashtbl.find revariable i in
196: j, vsplice caller_vars callee_vs_len ts
197: with Not_found -> i,ts
198: in
199: let i,ts = fixup i ts in
200: `BEXE_call_method_stack (sr,ge e1,i,ts, ge e2)
201:
202: | `BEXE_call_stack (sr,i,ts,e2) -> assert false
203: (*
204: let fixup i ts =
205: let ts = map auxt ts in
206: try
207: let j= Hashtbl.find revariable i in
208: j, vsplice caller_vars callee_vs_len ts
209: with Not_found -> i,ts
210: in
211: let i,ts = fixup i ts in
212: `BEXE_call_stack (sr,i,ts, ge e2)
213: *)
214:
215: (*
216: | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2) ->
217: print_endline ("Apply ctor " ^ si i1 ^ ", " ^ si i2 ^ ", [" ^
218: catmap "," (sbt syms.dfns) ts ^ "]" ^ si i3);
219: let fixup i ts =
220: let ts = map auxt ts in
221: try
222: let j= Hashtbl.find revariable i in
223: j, vsplice caller_vars callee_vs_len ts
224: with Not_found -> i,ts
225: in
226: let i2,ts = fixup i2 ts in
227: `BEXE_apply_ctor (sr,revar i1,i2,ts,revar i3,ge e2)
228:
229: | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2) ->
230: print_endline ("Apply ctor stack " ^ si i1 ^ ", " ^ si i2 ^ ", [" ^
231: catmap "," (sbt syms.dfns) ts ^ "]" ^ si i3);
232: let fixup i ts =
233: let ts = map auxt ts in
234: try
235: let j= Hashtbl.find revariable i in
236: j, vsplice caller_vars callee_vs_len ts
237: with Not_found -> i,ts
238: in
239: let i2,ts = fixup i2 ts in
240: `BEXE_apply_ctor_stack (sr,revar i1,i2,ts,revar i3,ge e2)
241: *)
242:
243: | x -> map_bexe revar ge ident relab relab x
244: in
245: (*
246: print_endline ("remapped_exe " ^ string_of_bexe syms.dfns 0 exe);
247: *)
248: exe
249:
250:
251: let remap_exes syms bbdfns relabel varmap revariable caller_vars callee_vs_len exes =
252: map (remap_exe syms bbdfns relabel varmap revariable caller_vars callee_vs_len) exes
253:
254: let remap_reqs syms bbdfns varmap revariable caller_vars callee_vs_len reqs : breqs_t =
255: let revar i = try Hashtbl.find revariable i with Not_found -> i in
256: let tmap t = match t with
257: | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
258: | x -> x
259: in
260: let auxt t =
261: map_btype tmap (varmap_subst varmap t)
262: in
263: let fixup (i, ts) =
264: let ts = map auxt ts in
265: try
266: let j= Hashtbl.find revariable i in
267: j, vsplice caller_vars callee_vs_len ts
268: with Not_found -> i,ts
269: in
270: map fixup reqs
271:
272:
273: (* this routine makes a (type) specialised version of a symbol:
274: a function, procedure, variable, or whatever.
275:
276: relabel: maps old labels onto fresh labels
277: revariable: maps old variables and functions to fresh ones
278: varmap: maps type variables to types (type specialisation)
279: index: this routine
280: parent: the new parent
281:
282: this routine doesn't specialise any children,
283: just any reference to them: the kids need
284: to be specialised by reparent_children.
285: *)
286:
287: let allow_rescan flag props =
288: match flag with
289: | false -> props
290: | true -> filter (function | `Inlining_complete | `Inlining_started -> false | _ -> true ) props
291:
292: let reparent1 (syms:sym_state_t) (uses,child_map,bbdfns )
293: relabel varmap revariable
294: caller_vs callee_vs_len index parent k rescan_flag
295: =
296: let splice vs = (* replace callee type variables with callers *)
297: vsplice caller_vs callee_vs_len vs
298: in
299: let sop = function
300: | None -> "NONE?"
301: | Some i -> si i
302: in
303: let caller_vars = map (fun (s,i) -> `BTYP_var (i,`BTYP_type 0)) caller_vs in
304:
305: let revar i = try Hashtbl.find revariable i with Not_found -> i in
306: let tmap t = match t with
307: | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
308: | x -> x
309: in
310: let auxt t =
311: map_btype tmap (varmap_subst varmap t)
312: in
313: let remap_ps ps = map (fun {pid=id; pindex=i; ptyp=t; pkind=k} ->
314: {pid=id; pindex=revar i; ptyp=auxt t; pkind=k})
315: ps
316: in
317:
318: let rexes xs = remap_exes syms bbdfns relabel varmap revariable caller_vars callee_vs_len xs in
319: let rexpr e = remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e in
320: let rreqs rqs = remap_reqs syms bbdfns varmap revariable caller_vars callee_vs_len rqs in
321: let id,old_parent,sr,entry = Hashtbl.find bbdfns index in
322: (*
323: print_endline
324: (
325: "COPYING " ^ id ^ " index " ^ si index ^ " with old parent " ^
326: sop old_parent ^ " to index " ^ si k ^ " with new parent " ^
327: sop parent
328: );
329: *)
330: begin match parent with
331: | Some p ->
332: let old_kids = try Hashtbl.find child_map p with Not_found -> [] in
333: (*
334: print_endline ("ADDING " ^ si k ^ " as child of " ^ si p);
335: *)
336: Hashtbl.replace child_map p (k::old_kids)
337: | None -> ()
338: end
339: ;
340: match entry with
341: | `BBDCL_procedure (props,vs,(ps,traint),exes) ->
342: let exes = rexes exes in
343: let ps = remap_ps ps in
344: let props = allow_rescan rescan_flag props in
345: let props = filter (fun p -> p <> `Virtual) props in
346: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_procedure (props,splice vs,(ps,traint),exes));
347: (*
348: print_endline "NEW PROCEDURE (clone):";
349: print_function syms.dfns bbdfns k;
350: *)
351: let calls = try Hashtbl.find uses index with Not_found -> [] in
352: let calls = map (fun (j,sr) -> revar j,sr) calls in
353: (*
354: print_endline ("Cal new usage of proc " ^ si k ^ ": " ^
355: catmap "," (fun (j,_) -> si j) calls);
356: *)
357: Hashtbl.add uses k calls
358:
359: | `BBDCL_function (props, vs, (ps,traint), ret, exes) ->
360: let props = allow_rescan rescan_flag props in
361: let props = filter (fun p -> p <> `Virtual) props in
362: let ps = remap_ps ps in
363: let exes = rexes exes in
364: let ret = auxt ret in
365: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_function (props,splice vs,(ps,traint),ret,exes));
366: (*
367: print_endline "NEW FUNCTION (clone):";
368: print_function syms.dfns bbdfns k;
369: *)
370: let calls = try Hashtbl.find uses index with Not_found -> [] in
371: let calls = map (fun (j,sr) -> revar j,sr) calls in
372: (*
373: print_endline ("Cal new usage of fun " ^ si k ^ ": " ^
374: catmap "," (fun (j,_) -> si j) calls);
375: *)
376: Hashtbl.add uses k calls
377:
378: | `BBDCL_var (vs,t) ->
379: (*
380: print_endline ("Reparent variable old: id<"^si index^"> vs=" ^
381: catmap "," (fun (s,i) -> s^"<"^si i^">") vs);
382: print_endline (" variable new: id<"^si k^"> vs=" ^
383: catmap "," (fun (s,i) -> s^"<"^si i^">") (splice vs));
384: *)
385: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_var (splice vs,auxt t))
386:
387: | `BBDCL_val (vs,t) ->
388: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_val (splice vs,auxt t))
389:
390: | `BBDCL_ref (vs,t) ->
391: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_ref (splice vs,auxt t))
392:
393: | `BBDCL_tmp (vs,t) ->
394: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_tmp (splice vs,auxt t))
395:
396: | `BBDCL_reglex (props,vs,(ps,traint),i,t,(a,j,h,m)) ->
397: let t = auxt t in
398: let ps = remap_ps ps in
399: let vs = splice vs in
400: let i = revar i in
401: let h2 = Hashtbl.create 13 in
402: Hashtbl.iter (fun x e -> Hashtbl.add h2 x (rexpr e)) h;
403: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_reglex (props,vs,(ps,traint),i,t,(a,j,h2,m)));
404: let calls = try Hashtbl.find uses index with Not_found -> [] in
405: let calls = map (fun (j,sr) -> revar j,sr) calls in
406: Hashtbl.add uses k calls
407:
408:
409: | `BBDCL_regmatch (props,vs,(ps,traint),t,(a,j,h,m)) ->
410: let t = auxt t in
411: let ps = remap_ps ps in
412: let vs = splice vs in
413: let h2 = Hashtbl.create 13 in
414: Hashtbl.iter (fun x e -> Hashtbl.add h2 x (rexpr e)) h;
415: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_regmatch (props,vs,(ps,traint),t,(a,j,h2,m)));
416: let calls = try Hashtbl.find uses index with Not_found -> [] in
417: let calls = map (fun (j,sr) -> revar j,sr) calls in
418: Hashtbl.add uses k calls
419:
420:
421: | `BBDCL_glr (props,vs,t,(prd,exes)) ->
422: let t = auxt t in
423: let vs = splice vs in
424: let exes = rexes exes in
425: let remap_glr g = match g with
426: | `Nonterm js -> `Nonterm (map revar js)
427: | x -> x (* terminal codes are invariant *)
428: in
429: let prd = map (fun (s,g) -> s,remap_glr g) prd in
430: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_glr (props,vs,t,(prd,exes)));
431: let calls = try Hashtbl.find uses index with Not_found -> [] in
432: let calls = map (fun (j,sr) -> revar j,sr) calls in
433: Hashtbl.add uses k calls
434:
435: | `BBDCL_class (props,vs) ->
436: let vs = splice vs in
437: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_class (props,vs));
438: let calls = try Hashtbl.find uses index with Not_found -> [] in
439: let calls = map (fun (j,sr) -> revar j,sr) calls in
440: Hashtbl.add uses k calls
441:
442:
443: | `BBDCL_abs (vs,quals,ct,breqs) ->
444: let vs = splice vs in
445: let breqs = rreqs breqs in
446: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_abs (vs,quals,ct,breqs));
447: let calls = try Hashtbl.find uses index with Not_found -> [] in
448: let calls = map (fun (j,sr) -> revar j,sr) calls in
449: Hashtbl.add uses k calls
450:
451:
452: | `BBDCL_const (vs,t,ct,breqs) ->
453: let vs = splice vs in
454: let breqs = rreqs breqs in
455: let t = auxt t in
456: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_const (vs,t,ct,breqs));
457: let calls = try Hashtbl.find uses index with Not_found -> [] in
458: let calls = map (fun (j,sr) -> revar j,sr) calls in
459: Hashtbl.add uses k calls
460:
461:
462: | `BBDCL_proc (props,vs,params,ct,breqs) ->
463: let props = filter (fun p -> p <> `Virtual) props in
464: let params = map auxt params in
465: let vs = splice vs in
466: let breqs = rreqs breqs in
467: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_proc (props,vs,params,ct,breqs));
468: let calls = try Hashtbl.find uses index with Not_found -> [] in
469: let calls = map (fun (j,sr) -> revar j,sr) calls in
470: (*
471: print_endline ("Cal new usage of proc " ^ si k ^ ": " ^
472: catmap "," (fun (j,_) -> si j) calls);
473: *)
474: Hashtbl.add uses k calls
475:
476: | `BBDCL_fun (props,vs,params,ret,ct,breqs,prec) ->
477: let props = filter (fun p -> p <> `Virtual) props in
478: let params = map auxt params in
479: let vs = splice vs in
480: let ret = auxt ret in
481: let breqs = rreqs breqs in
482: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_fun (props,vs,params,ret,ct,breqs,prec));
483: (*
484: print_endline "NEW FUNCTION (clone):";
485: print_function syms.dfns bbdfns k;
486: *)
487: let calls = try Hashtbl.find uses index with Not_found -> [] in
488: let calls = map (fun (j,sr) -> revar j,sr) calls in
489: (*
490: print_endline ("Cal new usage of fun " ^ si k ^ ": " ^
491: catmap "," (fun (j,_) -> si j) calls);
492: *)
493: Hashtbl.add uses k calls
494:
495: | `BBDCL_insert (vs,ct,ik,breqs) ->
496: let breqs = rreqs breqs in
497: let vs = splice vs in
498: Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_insert (vs,ct,ik,breqs));
499: let calls = try Hashtbl.find uses index with Not_found -> [] in
500: let calls = map (fun (j,sr) -> revar j,sr) calls in
501: Hashtbl.add uses k calls
502:
503: (*
504: | _ ->
505: Hashtbl.add bbdfns k (id,parent,sr,entry)
506: *)
507:
508: | _ -> syserr sr ("[reparent1] Unexpected: bbdcl " ^ string_of_bbdcl syms.dfns entry index)
509:
510: (* make a copy all the descendants of i, changing any
511: parent which is i to the given new parent
512: *)
513:
514: (* this routine reparents all the children of a given
515: routine, but it doesn't reparent the routine itself
516: *)
517:
518: let reparent_children syms (uses,child_map,bbdfns)
519: caller_vs callee_vs_len index parent relabel varmap rescan_flag
520: =
521: let pp p = match p with None -> "NONE" | Some i -> si i in
522: (*
523: print_endline
524: (
525: "Renesting children of callee " ^ si index ^
526: " to caller " ^ pp parent ^
527: "\n -- Caller vs len = " ^ si (length caller_vs) ^
528: "\n -- Callee vs len = " ^ si (callee_vs_len)
529: );
530: *)
531: let closure = descendants child_map index in
532: assert (not (IntSet.mem index closure));
533: (*
534: let cl = ref [] in IntSet.iter (fun i -> cl := i :: !cl) closure;
535: print_endline ("Closure is " ^ catmap " " si !cl);
536: *)
537: let revariable = mk_remap syms.counter closure in
538: IntSet.iter
539: (fun i ->
540: let old_parent =
541: match Hashtbl.find bbdfns i with id,oldp,_,_ -> oldp
542: in
543: let new_parent: bid_t option =
544: match old_parent with
545: | None -> assert false
546: | Some p ->
547: if p = index then parent
548: else Some (Hashtbl.find revariable p)
549: in
550: let k = Hashtbl.find revariable i in
551: reparent1 syms (uses,child_map,bbdfns) relabel varmap revariable
552: caller_vs callee_vs_len i new_parent k rescan_flag
553: )
554: closure
555: ;
556: if syms.compiler_options.print_flag then begin
557: Hashtbl.iter
558: (fun i j ->
559: print_endline ("//Reparent " ^ si j ^ " <-- " ^ si i)
560: )
561: revariable
562: end
563: ;
564: revariable
565:
566: (* NOTE! when we specialise a routine, calls to the same
567: routine (polymorphically recursive) need not end up
568: recursive. They're only recursive if they call the
569: original routine with the same type specialisations
570: as the one we're making here.
571:
572: In particular a call is recursive if, and only if,
573: it is fully polymorphic (that is, just resupplies
574: all the original type variables). In that case,
575: recursion is preserved by specialisation.
576:
577: However recursion can also be *introduced* by specialisation
578: where it didn't exist before!
579:
580: So remapping function indices has to be conditional.
581:
582: Note that calls to children HAVE to be remapped
583: because of reparenting -- the original kids
584: are no longer reachable! But this is no problem
585: because the kid's inherited type variables are
586: specialised away: you can't supply a kid with
587: type variable instances distinct from the kid's
588: parents variables (or the kid would refer to the
589: stack from of a distinct function!)
590:
591: So the only problem is on self calls of the main
592: routine, since they can call self either with
593: the current specialisation or any other.
594: *)
595:
596:
597: let specialise_symbol syms (uses,child_map,bbdfns)
598: caller_vs callee_vs_len index ts parent relabel varmap rescan_flag
599: =
600: try Hashtbl.find syms.transient_specialisation_cache (index,ts)
601: with Not_found ->
602: let k = !(syms.counter) in incr (syms.counter);
603: let revariable =
604: reparent_children syms (uses,child_map,bbdfns)
605: caller_vs callee_vs_len index (Some k) relabel varmap rescan_flag
606: in
607: reparent1 (syms:sym_state_t) (uses,child_map,bbdfns )
608: relabel varmap revariable
609: caller_vs callee_vs_len index parent k rescan_flag
610: ;
611: let caller_vars = map (fun (s,i) -> `BTYP_var (i,`BTYP_type 0)) caller_vs in
612: let ts' = vsplice caller_vars callee_vs_len ts in
613: Hashtbl.add syms.transient_specialisation_cache (index,ts) (k,ts');
614: k,ts'
615: