1: # 44 "./lpsrc/flx_spexes.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_call
21:
22:
23: type submode_t = [`Eager | `Lazy]
24:
25: module BidSet = IntSet
26:
27: (* this only updates the uses table not the usedby table,
28: because inlining changes usage (obviously).
29: we need it in particular for the is_recursive test,
30: so that tail recursions which have been eliminated
31: won't cause the test to return a false positive
32: *)
33:
34: let recal_exes_usage syms uses sr i ps exes =
35: (*
36: print_endline ("Recal usage of "^ si i^", this code:\n" ^ catmap "\n" (sbx syms.dfns) exes);
37: *)
38: (* delete old entry *)
39: (try Hashtbl.remove uses i with Not_found -> ());
40: iter (Flx_call.cal_param_usage syms uses sr i) ps;
41: iter (Flx_call.cal_exe_usage syms uses i) exes
42:
43: let is_tailed ps exes =
44: try iter
45: (function
46: | `BEXE_init(_,i,_) when mem i ps -> raise Not_found
47: | _ -> ()
48: )
49: exes;
50: false
51: with Not_found -> true
52:
53: let ident x = x
54:
55: (* Heavy inlining routine. This routine can inline
56: any procedure. The basic operation is emit the body
57: of the target procedure. We have to do the following to
58: make it all work.
59:
60: (1) Each declared label is replaced by a fresh one,
61: and all jumps to these labels modified accordingly.
62:
63: (2) Variables are replaced by fresh ones. This requires
64: making additions to the output bound tables. References
65: to the variables are modified. Note the parent is the
66: caller now.
67:
68: (3) Paremeters are replaced like variables, initialised
69: by the arguments.
70:
71: (4) Any type variables instantiated by the call must
72: also be instantiated in body expressions, as well as
73: the typing of any generated variables.
74:
75: (5) If the procedure has any nested procedures, they
76: also must be replaced in toto by fresh ones, reparented
77: to the caller so that any calls to them will access
78: the fresh variables in the caller.
79:
80: Note that the cache of children of the caller will
81: be wrong after the inlining (it may have acquired new
82: variables or procedure children).
83:
84: Note that this inlining procedure is NOT recursive!
85: Its a flat one level inlining. This ensures recursive
86: calls don't cause an infinite unrolling, and hopefully
87: prevent gross bloat.
88: *)
89:
90: let idt t = t
91:
92: let rec rpl syms argmap x = match map_tbexpr ident (rpl syms argmap) idt x with
93: (* No need to check ts or type here *)
94: | (`BEXPR_name (i,_),_) as x ->
95: (try
96: let x' = Hashtbl.find argmap i in
97: (*
98: print_endline ("Replacing variable " ^ si i ^ " with " ^ sbe syms.dfns x');
99: *)
100: x'
101: with Not_found -> x)
102: | x -> x
103:
104: let subarg syms bbdfns argmap exe =
105: map_bexe idt (rpl syms argmap) idt idt idt exe
106:
107: (* NOTE: result is in reversed order *)
108: let gen_body syms (uses,child_map,bbdfns) id
109: varmap ps relabel revariable exes argument
110: sr caller callee vs callee_vs_len inline_method props
111: =
112: if syms.compiler_options.print_flag then
113: print_endline ("Gen body caller = " ^ si caller ^
114: ", callee=" ^ id ^ "<" ^ si callee ^ ">"
115: );
116: (*
117: let argument = reduce_tbexpr bbdfns argument in
118: *)
119: let psis: int list = map (fun {pindex=i} -> i) ps in
120:
121: (* NOTE: this is the inline method for val's ONLY.
122: If a parameter is a var, it is inlined eagerly no
123: matter what .. however we can't handle that yet,
124: so we have to switch to eager evaluation if ANY
125: of the parameters is a var.
126: *)
127: let inline_method = match inline_method with
128: | `Lazy ->
129: if
130: Flx_call.is_recursive uses callee or
131: is_tailed psis exes
132: then `Eager
133: else `Lazy
134: (*
135: fold_left (fun imeth {pkind=k} ->
136: match imeth, k with
137: | _, `PVar -> `Eager
138: | x,_ -> x
139: )
140: `Lazy ps
141: *)
142: | `Eager -> `Eager
143: in
144:
145: (* HACKERY *)
146:
147: (*
148: let inline_method = `Eager in
149: *)
150:
151: (*
152: print_endline ("Inlining " ^ si callee ^ " into " ^ si caller);
153: *)
154: (*
155: begin match inline_method with
156: | `Eager ->
157: print_endline ("Eager INLINING " ^ id ^ "<"^si callee^">("^sbe syms.dfns argument^") into " ^ si caller ^ " .. INPUT:");
158: | `Lazy ->
159: print_endline ("Lazy INLINING " ^ id ^ "<"^si callee^">("^sbe syms.dfns argument^") into " ^ si caller ^ " .. INPUT:");
160: end
161: ;
162: iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) exes;
163: *)
164: let paramtype =
165: let pt =
166: let pts = map (fun {ptyp=t} -> t) ps in
167: match pts with
168: | [x] -> x
169: | x -> `BTYP_tuple x
170: in
171: varmap_subst varmap pt
172: in
173:
174: let caller_vars = map (fun (s,i) -> `BTYP_var (i,`BTYP_type 0)) vs in
175: let ge e = remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e in
176: let relab s = try Hashtbl.find relabel s with Not_found -> s in
177: let revar i = try Hashtbl.find revariable i with Not_found -> i in
178: let end_label_uses = ref 0 in
179: let end_label =
180: let end_index = !(syms.counter) in
181: incr syms.counter;
182: "_end_" ^ (si end_index)
183: in
184:
185:
186: let remap: bexe_t -> bexe_t list = fun exe ->
187: match exe with
188: | `BEXE_axiom_check _ -> assert false
189: | `BEXE_call_prim (sr,i,ts,e2) -> assert false
190: (*
191: let fixup i ts =
192: let auxt t = varmap_subst varmap t in
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_prim (sr,i,ts, ge e2)]
201: *)
202:
203: | `BEXE_call_direct (sr,i,ts,e2) -> assert false
204: (*
205: let fixup i ts =
206: let auxt t = varmap_subst varmap t in
207: let ts = map auxt ts in
208: try
209: let j= Hashtbl.find revariable i in
210: j, vsplice caller_vars callee_vs_len ts
211: with Not_found -> i,ts
212: in
213: let i,ts = fixup i ts in
214: [`BEXE_call_direct (sr,i,ts, ge e2)]
215: *)
216:
217: | `BEXE_call_method_direct (sr,e1,i,ts,e2) ->
218: let fixup i ts =
219: let auxt t = varmap_subst varmap t in
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 i,ts = fixup i ts in
227: [`BEXE_call_method_direct (sr,ge e1,i,ts, ge e2)]
228:
229: | `BEXE_call_method_stack (sr,e1,i,ts,e2) ->
230: let fixup i ts =
231: let auxt t = varmap_subst varmap t in
232: let ts = map auxt ts in
233: try
234: let j= Hashtbl.find revariable i in
235: j, vsplice caller_vars callee_vs_len ts
236: with Not_found -> i,ts
237: in
238: let i,ts = fixup i ts in
239: [`BEXE_call_method_stack (sr,ge e1,i,ts, ge e2)]
240:
241: | `BEXE_jump_direct (sr,i,ts,e2) ->
242: let fixup i ts =
243: let auxt t = varmap_subst varmap t in
244: let ts = map auxt ts in
245: try
246: let j= Hashtbl.find revariable i in
247: j, vsplice caller_vars callee_vs_len ts
248: with Not_found -> i,ts
249: in
250: let i,ts = fixup i ts in
251: [`BEXE_jump_direct (sr,i,ts, ge e2)]
252:
253: | `BEXE_call_stack (sr,i,ts,e2) -> assert false
254:
255: | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2) ->
256: let fixup i ts =
257: let auxt t = varmap_subst varmap t in
258: let ts = map auxt ts in
259: try
260: let j= Hashtbl.find revariable i in
261: j, vsplice caller_vars callee_vs_len ts
262: with Not_found -> i,ts
263: in
264: let i2,ts = fixup i2 ts in
265: let rv i = try Hashtbl.find revariable i with Not_found -> i in
266: [`BEXE_apply_ctor (sr,rv i1, i2,ts,rv i3,ge e2)]
267:
268: | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2) ->
269: let fixup i ts =
270: let auxt t = varmap_subst varmap t in
271: let ts = map auxt ts in
272: try
273: let j= Hashtbl.find revariable i in
274: j, vsplice caller_vars callee_vs_len ts
275: with Not_found -> i,ts
276: in
277: let i2,ts = fixup i2 ts in
278: let rv i = try Hashtbl.find revariable i with Not_found -> i in
279: [`BEXE_apply_ctor_stack (sr,rv i1, i2,ts,rv i3,ge e2)]
280:
281: | `BEXE_call (sr,e1,e2) -> [`BEXE_call (sr,ge e1, ge e2)]
282: | `BEXE_jump (sr,e1,e2) -> assert false
283:
284: | `BEXE_loop (sr,i,e) -> assert false
285:
286: | `BEXE_assert (sr,e) -> [`BEXE_assert (sr, ge e)]
287: | `BEXE_assert2 (sr,sr2,e1,e2) ->
288: let e1 = match e1 with Some e1 -> Some (ge e1) | None -> None in
289: [`BEXE_assert2 (sr, sr2, e1,ge e2)]
290:
291: | `BEXE_ifgoto (sr,e,lab) -> [`BEXE_ifgoto (sr,ge e, relab lab)]
292: | `BEXE_ifnotgoto (sr,e,lab) -> [`BEXE_ifnotgoto (sr,ge e, relab lab)]
293: | `BEXE_fun_return (sr,e) -> [`BEXE_fun_return (sr, ge e)]
294: | `BEXE_yield (sr,e) -> [`BEXE_yield (sr, ge e)]
295: | `BEXE_assign (sr,e1,e2) -> [`BEXE_assign (sr, ge e1, ge e2)]
296: | `BEXE_init (sr,i,e) -> [`BEXE_init (sr,revar i, ge e)]
297: | `BEXE_svc (sr,i) -> [`BEXE_svc (sr, revar i)]
298:
299: | `BEXE_code (sr,s) as x -> [x]
300: | `BEXE_nonreturn_code (sr,s) as x -> [x]
301: | `BEXE_goto (sr,lab) -> [`BEXE_goto (sr, relab lab)]
302:
303:
304: (* INLINING THING *)
305: | `BEXE_proc_return sr as x ->
306: incr end_label_uses;
307: [`BEXE_goto (sr,end_label)]
308:
309: | `BEXE_comment (sr,s) as x -> [x]
310: | `BEXE_nop (sr,s) as x -> [x]
311: | `BEXE_halt (sr,s) as x -> [x]
312: | `BEXE_label (sr,lab) -> [`BEXE_label (sr, relab lab)]
313: | `BEXE_begin as x -> [x]
314: | `BEXE_end as x -> [x]
315: in
316: let kind = match inline_method with
317: | `Lazy -> "Lazy "
318: | `Eager -> "Eager "
319: in
320: let rec fgc props s =
321: match props with
322: | [] -> String.concat ", " s
323: | `Generated x :: t -> fgc t (x :: s)
324: | _ :: t -> fgc t s
325: in
326: let source =
327: let x = fgc props [] in
328: if x <> "" then " (Generated "^x^")" else ""
329: in
330: (* add a comment for non-generated functions .. *)
331: let b =
332: ref
333: (
334: if source = "" && id <> "_init_" then
335: [`BEXE_comment (sr,(kind ^ "inline call to " ^ id ^source))]
336: else []
337: )
338: in
339: (*
340: if inline_method = `Eager then begin
341: (* create a variable for the parameter *)
342: let parameter = !(syms.counter) in
343: incr syms.counter;
344: let param_id = "_p" ^ si parameter in
345: (*
346: print_endline ("Parameter assigned index " ^ si parameter);
347: *)
348:
349: (* create variables for parameter components *)
350: (* Whaaa??
351: if length ps > 1 then
352: for i = 1 to length ps do incr syms.counter done;
353: (* Initialise parameter to argument, but only if
354: the argument is not unit
355: *)
356: *)
357: if length ps > 0 then
358: begin
359: let x =
360: if length ps > 1
361: then begin
362: let entry = `BBDCL_var (vs,paramtype) in
363: let kids =
364: try Hashtbl.find child_map caller
365: with Not_found -> []
366: in
367: Hashtbl.replace child_map caller (parameter::kids);
368: Hashtbl.add bbdfns parameter (param_id,Some caller,sr,entry);
369: `BEXE_init (sr,parameter,argument)
370: end
371: else
372: let {pid=vid; pindex=k} = hd ps in
373: let index = revar k in
374: `BEXE_init (sr,index,argument)
375: in
376: b := x :: !b;
377:
378: (* unpack argument *)
379: if length ps > 1 then
380: let ts = map (fun (_,i) -> `BTYP_var (i,`BTYP_type 0)) vs in
381: let p = `BEXPR_name (parameter,ts),paramtype in
382: let n = ref 0 in
383: iter
384: (fun {pid=vid;pindex=ix; ptyp=prjt} ->
385: let prjt = varmap_subst varmap prjt in
386: let pj =
387: match argument with
388: (* THIS CASE MAY NOT WORK WITH TAIL REC OPT! *)
389: | `BEXPR_tuple ls,_ ->
390: begin try nth ls (!n)
391: with _ -> failwith "Woops, tuple wrong length?"
392: end
393: | _ -> `BEXPR_get_n (!n,p),prjt
394: in
395: (*
396: let prj = reduce_tbexpr bbdfns pj in
397: *)
398: let prj = pj in
399: let index = revar ix in
400: let x = `BEXE_init (sr,index,prj) in
401: b := x :: !b;
402: incr n
403: )
404: ps
405: end
406: ;
407: iter
408: (fun exe ->
409: iter
410: (fun x -> b := x :: !b)
411: (remap exe)
412: )
413: exes
414: end else if inline_method = `Lazy then begin
415: *)
416: let argmap = Hashtbl.create 97 in
417: begin match length ps with
418: | 0 -> ()
419: | 1 ->
420: let {pkind=kind; pid=vid; pindex=k; ptyp=ptyp} = hd ps in
421: let index = revar k in
422: begin match kind with
423: | `PFun ->
424: let argt = match argument with
425: | _,`BTYP_function (`BTYP_void,t)
426: | _,`BTYP_function (`BTYP_tuple [],t) -> t
427: | _,t -> failwith ("Expected argument to be function void->t, got " ^ sbt syms.dfns t)
428: in
429: let un = `BEXPR_tuple [], `BTYP_tuple [] in
430: let apl = `BEXPR_apply (argument, un), argt in
431: Hashtbl.add argmap index apl
432:
433: | `PVal when inline_method = `Lazy ->
434: Hashtbl.add argmap index argument
435:
436: | `PRef ->
437: begin match argument with
438: | `BEXPR_ref (i,ts),`BTYP_pointer t ->
439: Hashtbl.add argmap index (`BEXPR_name (i,ts),t)
440: | _ ->
441: let x = `BEXE_init (sr,index,argument) in
442: b := x :: !b
443: end
444:
445: | `PVal when inline_method = `Eager ->
446: let x = `BEXE_init (sr,index,argument) in
447: b := x :: !b
448:
449: | `PVar ->
450: let x = `BEXE_init (sr,index,argument) in
451: b := x :: !b
452:
453: | _ -> failwith "Can't handle ref/fun params yet"
454: end
455:
456: | _ ->
457: (* create a variable for the parameter *)
458: let parameter = !(syms.counter) in
459: incr syms.counter;
460: let param_id = "_p" ^ si parameter in
461: (*
462: print_endline ("Parameter assigned index " ^ si parameter);
463: *)
464:
465: let ts = map (fun (_,i) -> `BTYP_var (i,`BTYP_type 0)) vs in
466: let n = ref 0 in
467: iter
468: (fun {pkind=kind; pid=vid; pindex=ix; ptyp=prjt} ->
469: let prjt = varmap_subst varmap prjt in
470: let pj =
471: match argument with
472: (* THIS CASE MAY NOT WORK WITH TAIL REC OPT! *)
473: | `BEXPR_tuple ls,_ ->
474: begin try nth ls (!n)
475: with _ -> failwith "Woops, tuple wrong length?"
476: end
477: | p -> `BEXPR_get_n (!n,p),prjt
478: in
479: (*
480: let prj = reduce_tbexpr bbdfns pj in
481: *)
482: let prj = pj in
483: let index = revar ix in
484: begin match kind with
485: | `PFun ->
486: let t = match prj with
487: | _,`BTYP_function (`BTYP_void,t)
488: | _,`BTYP_function (`BTYP_tuple [],t) -> t
489: | _ -> failwith "Expected argument to be function void->t!"
490: in
491: let un = `BEXPR_tuple [], `BTYP_tuple [] in
492: let apl = `BEXPR_apply (prj,un),t in
493: Hashtbl.add argmap index apl
494:
495: | `PVal when inline_method = `Lazy ->
496: Hashtbl.add argmap index prj
497:
498: | `PRef ->
499: begin match prj with
500: | `BEXPR_ref (i,ts),`BTYP_pointer t ->
501: Hashtbl.add argmap index (`BEXPR_name (i,ts),t)
502: | _ ->
503: let x = `BEXE_init (sr,index,prj) in
504: b := x :: !b
505: end
506:
507: | `PVal when inline_method = `Eager ->
508: let x = `BEXE_init (sr,index,prj) in
509: b := x :: !b
510:
511: | `PVar ->
512: let x = `BEXE_init (sr,index,prj) in
513: b := x :: !b
514:
515: | _ -> failwith "Can't handle ref/fun params yet"
516: end
517: ;
518: incr n
519: )
520: ps
521: end
522: ;
523: (*
524: print_endline "argmap = ";
525: Hashtbl.iter
526: (fun i e ->
527: try
528: let id,_,_,_ = Hashtbl.find bbdfns i in
529: print_endline (id ^ "<"^ si i ^ "> --> " ^ sbe syms.dfns e)
530: with Not_found -> print_endline ("Can't find index .." ^ si i)
531: )
532: argmap
533: ;
534: print_endline "----::----";
535: *)
536: let sba = if Hashtbl.length argmap = 0 then
537: fun x -> b := x :: !b
538: else
539: fun x -> b := subarg syms bbdfns argmap x :: !b
540: in
541: iter
542: (fun exe -> iter sba (remap exe))
543: exes
544: ;
545: (*
546: print_endline "Lazy evaluation, output=";
547: iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) (rev !b);
548: *)
549: (* substitute in kids too *)
550: if Hashtbl.length argmap > 0 then begin
551: let closure = descendants child_map callee in
552: (*
553: let cl = ref [] in IntSet.iter (fun i -> cl := i :: !cl) closure;
554: print_endline ("Closure is " ^ catmap " " si !cl);
555: *)
556: let kids =
557: IntSet.fold
558: (fun i s -> IntSet.add (revar i) s)
559: closure
560: IntSet.empty
561: in
562: IntSet.iter (fun i ->
563: let id,parent,sr,entry = Hashtbl.find bbdfns i in
564: match entry with
565: | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
566: let exes = map (subarg syms bbdfns argmap) exes in
567: recal_exes_usage syms uses sr i ps exes;
568: Hashtbl.replace bbdfns i
569: (id,parent,sr,`BBDCL_function (props,vs,(ps,traint),ret,exes))
570:
571: | `BBDCL_procedure (props,vs,(ps,traint),exes) ->
572: (*
573: print_endline ("MODIFY " ^ si i);
574: *)
575: let exes = map (subarg syms bbdfns argmap) exes in
576: recal_exes_usage syms uses sr i ps exes;
577: Hashtbl.replace bbdfns i
578: (id,parent,sr,`BBDCL_procedure (props,vs,(ps,traint),exes))
579:
580: | `BBDCL_regmatch (props,vs,(ps,traint),ret,(alpha,states,h,mx)) ->
581: (try Hashtbl.remove uses i with Not_found -> ());
582: iter (cal_param_usage syms uses sr i) ps;
583: let h2 = Hashtbl.create 97 in
584: Hashtbl.iter (fun k x ->
585: let x = rpl syms argmap x in
586: Hashtbl.add h2 k x;
587: cal_expr_usage syms uses i sr x
588: )
589: h
590: ;
591: Hashtbl.replace bbdfns i
592: (id,parent,sr,`BBDCL_regmatch (props,vs,(ps,traint),ret,(alpha,states,h2,mx)))
593:
594: | `BBDCL_reglex (props,vs,(ps,traint),j,ret,(alpha,states,h,mx)) ->
595: (try Hashtbl.remove uses i with Not_found -> ());
596: iter (cal_param_usage syms uses sr i) ps;
597: let h2 = Hashtbl.create 97 in
598: Hashtbl.iter (fun k x ->
599: let x = rpl syms argmap x in
600: Hashtbl.add h2 k x;
601: cal_expr_usage syms uses i sr x
602: )
603: h
604: ;
605: Hashtbl.replace bbdfns i
606: (id,parent,sr,`BBDCL_reglex (props,vs,(ps,traint),j,ret,(alpha,states,h2,mx)))
607:
608: | _ -> ()
609: )
610: kids
611: end
612: ;
613: let trail_jump = match !b with
614: | `BEXE_goto (_,lab)::_ when lab = end_label -> true
615: | _ -> false
616: in
617: if trail_jump then
618: (b := tl !b; decr end_label_uses)
619: ;
620: if !end_label_uses > 0 then
621: b := (`BEXE_label (sr,end_label)) :: !b
622: ;
623: (*
624: print_endline ("INLINING " ^ id ^ " into " ^ si caller ^ " .. OUTPUT:");
625: iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) (rev !b);
626: print_endline ("END OUTPUT for " ^ id);
627: *)
628: !b
629:
630: