1: # 24 "./lpsrc/flx_foldvars.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:
22: let string_of_intset s =
23: "{ " ^
24: IntSet.fold (fun i x -> x ^ si i ^ " ") s "" ^
25: "}"
26:
27:
28: let ident x = x
29:
30: let useset uses i =
31: let u = try Hashtbl.find uses i with Not_found -> [] in
32: fold_left (fun s (i,_) -> IntSet.add i s) IntSet.empty u
33:
34: (* remove all uses of j from i *)
35: let remove_uses uses i j =
36: (*
37: print_endline "Eliding " ^ si i ^ " from " ^ si j);
38: *)
39: try
40: let u = Hashtbl.find uses i in
41: let u = filter (fun (k,sr) -> j <> k) u in
42: Hashtbl.replace uses i u
43: with Not_found -> ()
44:
45: let add_use uses i j sr =
46: let u = try Hashtbl.find uses i with Not_found -> [] in
47: Hashtbl.replace uses i ((j,sr) :: u)
48:
49:
50: (* find all the variables of a function i which
51: are not used by children, this is the kids
52: minus just the union of everything used by the
53: child functions.
54: *)
55: let locals child_map uses i =
56: let kids = intset_of_list (find_children child_map i) in
57: (*
58: print_endline ("Kid of " ^ si i ^ " = " ^ string_of_intset kids);
59: *)
60: (*
61: let u = useset uses i in
62: *)
63: let u = Flx_call.child_use_closure kids uses i in
64: let unused_kids = IntSet.diff kids u in
65: (*
66: print_endline ("Unused kids are " ^ si i ^ " = " ^ string_of_intset unused_kids);
67: *)
68: let used_kids = IntSet.diff kids unused_kids in
69: (*
70: print_endline ("Used kids are " ^ si i ^ " = " ^ string_of_intset used_kids);
71: *)
72: (*
73: let desc = descendants child_map i in
74: *)
75: let desc =
76: IntSet.fold
77: (fun j s -> let u = descendants child_map j in IntSet.union u s)
78: used_kids
79: IntSet.empty
80: in
81: (*
82: print_endline ("Descendants of " ^ si i ^ " = " ^ string_of_intset desc);
83: *)
84: let u =
85: IntSet.fold
86: (fun j s ->
87: let u = useset uses j in
88: (*
89: print_endline ("Descendant " ^ si j ^ " of " ^ si i ^ " uses " ^ string_of_intset u);
90: *)
91: IntSet.union s u
92: )
93: desc
94: IntSet.empty
95: in
96: (*
97: print_endline ("Stuff used by some descendant = " ^ string_of_intset u);
98: *)
99: IntSet.diff kids u
100:
101:
102: let fold_vars syms (uses,child_map,bbdfns) i ps exes =
103: let pset = fold_left (fun s {pindex=i}-> IntSet.add i s) IntSet.empty ps in
104: let kids = find_children child_map i in
105: let id,_,_,_ = Hashtbl.find bbdfns i in
106: (*
107: print_endline ("\nFOLDing " ^ id ^ "<" ^ si i ^">");
108: print_endline ("Kids = " ^ catmap ", " si kids);
109: *)
110: let descend = descendants child_map i in
111: (*
112: print_endline ("Descendants are " ^ string_of_intset descend);
113: *)
114: let locls = locals child_map uses i in
115: (*
116: print_endline ("Locals of " ^ si i ^ " are " ^ string_of_intset locls);
117: print_endline "INPUT Code is";
118: iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
119: *)
120:
121: let elim_pass exes =
122: let count = ref 0 in
123: let rec find_tassign inexes outexes =
124: match inexes with
125: | [] -> rev outexes
126: | ((
127: `BEXE_init (_,j,y)
128: | `BEXE_assign (_, (`BEXPR_name (j,_),_),y)
129: ) as x) :: t when IntSet.mem j locls ->
130:
131: let id,_,_,_ = Hashtbl.find bbdfns j in
132: (*
133: print_endline ("CONSIDERING VARIABLE " ^ id ^ "<" ^ si j ^ "> -> " ^ sbe syms.dfns y);
134: *)
135: (* does uses include initialisations or not ..?? *)
136:
137: (* check if the variable is used by any descendants *)
138: let nlocal_uses =
139: IntSet.fold
140: (fun child u ->
141: let luses = Flx_call.use_closure uses child in
142: u || IntSet.mem j luses
143: )
144: descend
145: false
146: in
147: if nlocal_uses then begin
148: (*
149: print_endline "VARIABLE USED NONLOCALLY";
150: *)
151: find_tassign t (x::outexes)
152: end else
153:
154: (* count all local uses of the variable: there are no others *)
155: let usecnt =
156: let luses = try Hashtbl.find uses i with Not_found -> [] in
157: fold_left (fun u (k,sr) -> if k = j then u+1 else u) 0 luses
158: in
159: (*
160: print_endline ("Use count = " ^ si usecnt);
161: *)
162: let setcnt = ref (if IntSet.mem j pset then 2 else 1) in
163: let sets exe =
164: match exe with
165: | `BEXE_init (_,k,_) when j = k -> incr setcnt
166: | _ -> ()
167: in
168: iter sets t; iter sets outexes;
169: (*
170: print_endline ("Set count = " ^ si !setcnt);
171: *)
172: let yuses = Flx_call.expr_uses syms descend uses pset y in
173: let delete_var () =
174: let id,_,_,_ = Hashtbl.find bbdfns j in
175: if syms.compiler_options.print_flag then
176: print_endline ("ELIMINATING VARIABLE " ^ id ^ "<" ^ si j ^ "> -> " ^ sbe syms.dfns y);
177:
178: (* remove the variable *)
179: Hashtbl.remove bbdfns j;
180: remove_child child_map i j;
181: remove_uses uses i j;
182: incr count
183: in
184: let isvar =
185: match Hashtbl.find bbdfns j with
186: | _,_,_,(`BBDCL_var _ | `BBDCL_tmp _ | `BBDCL_ref _ ) -> true
187: | _,_,_,`BBDCL_val _ -> false
188: | _ -> assert false
189: in
190:
191: (* Cannot do anything with variables or multiply assigned values
192: so skip to next instruction -- this is a tail-recursive call
193: *)
194: if isvar or !setcnt > 1 then begin
195: (*
196: print_endline "IS VAR or SETCNT > 1";
197: *)
198: find_tassign t (x::outexes)
199:
200: (* otherwise it is a value and it is set at most once *)
201:
202: (* it is not used anywhere (except the init) *)
203: end else if usecnt = 1 then begin
204: if syms.compiler_options.print_flag then
205: print_endline ("WARNING: unused variable "^si j^" found ..");
206: delete_var();
207: find_tassign t outexes
208:
209: (* OK, it is used at least once *)
210: end else
211: (* count elision of the init as 1 *)
212: let rplcnt = ref 1 in
213: let subi,rplimit =
214: match y with
215: | `BEXPR_tuple ys,_ ->
216: (*
217: print_endline "Tuple init found";
218: *)
219: let rec subi j ys e =
220: match map_tbexpr ident (subi j ys) ident e with
221: | `BEXPR_get_n (k, (`BEXPR_name(i,_),_) ),_
222: when j = i ->
223: (*
224: print_endline ("Replacing " ^ sbe syms.dfns e);
225: *)
226: incr rplcnt; nth ys k
227: | x -> x
228: in subi j ys, length ys + 1
229: | _ ->
230: let rec subi j y e =
231: match map_tbexpr ident (subi j y) ident e with
232: | `BEXPR_name (i,_),_ when j = i -> incr rplcnt; y
233: | x -> x
234: in subi j y, 2 (* take init into account *)
235: in
236: let elimi exe =
237: map_bexe ident subi ident ident ident exe
238: in
239: let subs = ref true in
240: let elim exes = map
241: (fun exe ->
242: (*
243: print_endline ("In Exe = " ^ string_of_bexe syms.dfns 2 exe);
244: *)
245: if !subs then
246: match exe with
247: | `BEXE_axiom_check _ -> assert false
248:
249: (* terminate substitution, return unmodified instr *)
250: | `BEXE_goto _
251: | `BEXE_proc_return _
252: | `BEXE_label _
253: -> subs:= false; exe
254:
255: (* return unmodified instr *)
256: | `BEXE_begin
257: | `BEXE_end
258: | `BEXE_nop _
259: | `BEXE_code _
260: | `BEXE_nonreturn_code _
261: | `BEXE_comment _
262: | `BEXE_halt _
263: -> exe
264:
265: (* conditional, check if y depends on init (tail rec) *)
266:
267: | `BEXE_assign (_,(`BEXPR_name (k,_),_),_)
268: | `BEXE_svc (_,k)
269: | `BEXE_init (_,k,_) ->
270: subs := not (IntSet.mem k yuses);
271: elimi exe
272:
273: (* return modified instr *)
274: | `BEXE_ifgoto _
275: | `BEXE_ifnotgoto _
276: | `BEXE_assert _
277: | `BEXE_assert2 _
278: -> elimi exe
279:
280: (* terminate substitution, return modified instr *)
281: | `BEXE_apply_ctor _
282: | `BEXE_apply_ctor_stack _
283: | `BEXE_assign _
284: | `BEXE_fun_return _
285: | `BEXE_yield _
286: | `BEXE_jump _
287: | `BEXE_jump_direct _
288: | `BEXE_loop _
289: | `BEXE_call_prim _
290: | `BEXE_call _
291: | `BEXE_call_direct _
292: | `BEXE_call_method_direct _
293: | `BEXE_call_method_stack _
294: | `BEXE_call_stack _
295: -> subs := false; elimi exe
296: else exe
297: )
298: exes
299: in
300: let t' = elim t in
301: if !rplcnt > rplimit then
302: begin
303: if syms.compiler_options.print_flag then
304: print_endline (
305: "Warning: replacement count " ^
306: si !rplcnt ^
307: " exceeds replacement limit " ^
308: si rplimit
309: );
310: find_tassign t (x::outexes)
311: end
312: else if !rplcnt <> usecnt then
313: begin
314: if syms.compiler_options.print_flag then
315: print_endline (
316: "Warning: replacement count " ^
317: si !rplcnt ^
318: " not equal to usage count " ^
319: si usecnt
320: );
321: find_tassign t (x::outexes)
322: end
323: else
324: begin
325: delete_var();
326: (*
327: print_endline ("DELETE VAR "^si j^", ELIMINATING Exe = " ^ string_of_bexe syms.dfns 0 x);
328: *)
329: find_tassign t' outexes
330: end
331:
332: | h::t -> find_tassign t (h::outexes)
333: in
334: !count,find_tassign exes []
335: in
336: let master_count = ref 0 in
337: let iters = ref 0 in
338: let rec elim exes =
339: let count,exes = elim_pass exes in
340: incr iters;
341: master_count := !master_count + count;
342: if count > 0 then elim exes else exes
343: in
344: let exes = elim exes in
345:
346: (*
347: if syms.compiler_options.print_flag then
348: *)
349: if !master_count > 0 then begin
350: if syms.compiler_options.print_flag then
351: print_endline ("Removed " ^ si !master_count ^" variables in " ^ si !iters ^ " passes");
352: (*
353: print_endline "OUTPUT Code is";
354: iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
355: *)
356: end
357: ;
358: exes
359:
360: