1: # 50 "./lpsrc/flx_call.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_srcref
5: open Flx_mtypes1
6: open List
7: open Flx_exceptions
8: open Flx_maps
9: open Flx_util
10: open Flx_print
11: open Flx_mtypes2
12:
13: type usage_table_t = (bid_t, (bid_t * range_srcref) list) Hashtbl.t
14: type usage_t = usage_table_t * usage_table_t
15:
16: let add (h:usage_table_t) k j sr =
17: (*
18: print_endline ("Adding use of " ^ si j ^ " in " ^ si k);
19: *)
20: Hashtbl.replace h k
21: (
22: (j,sr)
23: ::
24: (
25: try Hashtbl.find h k
26: with Not_found -> []
27: )
28: )
29:
30: let rec process_expr h k sr ((e,t) as be) =
31: let ue e = process_expr h k sr e in
32: let ui i = add h k i sr in
33: (* Use the flx_maps iterator now! *)
34: iter_tbexpr ui ignore ignore be
35:
36: and cal_exe_usage syms h k exe =
37: (*
38: print_endline ("Checking uses in " ^ si k ^ ", exe: " ^ string_of_bexe syms.dfns 2 exe);
39: *)
40: let sr = src_of_bexe exe in
41: let ue e = process_expr h k sr e in
42: let ui i = add h k i sr in
43: (* USE A MAP *)
44: iter_bexe ui ue ignore ignore ignore exe
45:
46: let uses_production h k sr p =
47: let uses_symbol (_,nt) = match nt with
48: | `Nonterm jj -> iter (fun i -> add h k i sr) jj
49: | `Term _ -> () (* HACK! This is a union constructor name we need to 'use' the union type!! *)
50: in
51: iter uses_symbol p
52:
53: let cal_param_usage syms uses sr parent (_,(child,_)) =
54: add uses parent child sr
55:
56: let call_data syms (bbdfns:fully_bound_symbol_table_t):usage_t =
57: let uses = Hashtbl.create 97 in
58: let usedby = Hashtbl.create 97 in
59: let usage = uses,usedby in
60: Hashtbl.iter
61: (fun k (_,_,sr,entry) -> match entry with
62: | `BBDCL_procedure (_,_,(ps,_),exes)
63: | `BBDCL_function (_,_,(ps,_),_,exes) ->
64: iter (cal_param_usage syms uses sr k) ps;
65: iter (cal_exe_usage syms uses k) exes
66:
67: | `BBDCL_glr (_,_,_,(p,exes)) ->
68: iter (cal_exe_usage syms uses k) exes;
69: uses_production uses k sr p
70:
71: | `BBDCL_regmatch (_,_,(ps,_),_,(_,_,h,_))
72: | `BBDCL_reglex (_,_,(ps,_),_,_,(_,_,h,_)) ->
73: iter (cal_param_usage syms uses sr k) ps;
74: Hashtbl.iter (fun _ e -> process_expr uses k sr e) h
75:
76: | _ -> ()
77: )
78: bbdfns
79: ;
80: (* invert uses table to get usedby table *)
81: Hashtbl.iter
82: (fun k ls ->
83: iter
84: (fun (i,sr) -> add usedby i k sr)
85: ls
86: )
87: uses
88: ;
89: usage
90:
91: (* closure of i, excluding i unless it is recursive! *)
92: let cls h i =
93: let c = ref IntSet.empty in
94: let rec add j =
95: if not (IntSet.mem j !c) then
96: begin
97: c := IntSet.add j !c;
98: let x = try Hashtbl.find h j with Not_found -> [] in
99: iter (fun (j,_) -> add j) x
100: end
101: in
102: let x = try Hashtbl.find h i with Not_found -> [] in
103: iter (fun (j,_) -> add j) x
104: ;
105: !c
106:
107: let is_recursive_call h caller callee = IntSet.mem caller (cls h callee)
108: let is_recursive h i = is_recursive_call h i i
109:
110: let use_closure h i = cls h i
111:
112: (* this calculates the use closure of i, eliminating recursive
113: calls to the base function by restricting references
114: to some set k. Note this means the usage of k is also
115: not included.
116:
117: If k is set to the children of some function f,
118: then this routine will not report usage of any
119: variables in f via calls to f, only direct
120: uses in some child which is called; in particular
121: calls to outside the child tree of f are not tracked
122: since they can't call any children of f,
123: so they can only use them via a call to f.
124: This would spawn a new stack frame, and so
125: refer to different copies of variables.
126:
127: This routine is used to find which variables
128: in f an expression in f can use via a call to a child.
129:
130: OUCH OUCH OUCH. I THINK THIS IDEA MUST BE BUGGED!
131:
132: Here's the problem. Given
133:
134: fun A(){
135: fun B { fun C() {} return C; }
136: fun D(f) { f 1; }
137: D (B());
138: }
139:
140: function B is returning a closure of C,
141: which is being passed into D and called.
142: Note D cannot see the function C.
143:
144: The inliner should handle this correctly:
145: B is inlined to return a *clone* C' of C which
146: is nested in A, then D is inlined, resulting
147: in the call C' 1 (which can now be inlined too).
148:
149: The problem is that the assumption "calls outside
150: the child tree of f are not tracked since they can't
151: call any children of f" is wrong. A call outside
152: the tree can still execute something inside
153: the tree via a closure .. however how does the
154: closure get out .. it has to be 'made' by someon
155: who can see it ..
156:
157: *)
158:
159: let child_use_closure k h i =
160: let c = ref IntSet.empty in
161: let rec add j =
162: if not (IntSet.mem j !c) && IntSet.mem j k then
163: begin
164: c := IntSet.add j !c;
165: let x = try Hashtbl.find h j with Not_found -> [] in
166: iter (fun (j,_) -> add j) x
167: end
168: in
169: let x = try Hashtbl.find h i with Not_found -> [] in
170: iter (fun (j,_) -> add j) x
171: ;
172: !c
173:
174:
175: let call_report syms bbdfns (uses,usedby) f k =
176: let si = string_of_int in
177: let catmap = Flx_util.catmap in
178: let w s = output_string f s in
179: let isr = is_recursive uses k in
180: let id,_,sr,entry = Hashtbl.find bbdfns k in
181: w (si k ^ ": ");
182: w (if isr then "recursive " else "");
183: w
184: begin match entry with
185: | `BBDCL_function _ -> "fun "
186: | `BBDCL_procedure _ -> "proc "
187: | `BBDCL_var _ -> "var "
188: | `BBDCL_val _ -> "val "
189: | _ -> assert false
190: end
191: ;
192: w (id ^ " uses: ");
193: let u = try Hashtbl.find uses k with Not_found -> [] in
194: let x = ref [] in
195: iter
196: (fun (i,_) ->
197: if not (mem i !x) then
198: try match Hashtbl.find bbdfns i with
199: | _,_,_,`BBDCL_procedure _
200: | _,_,_,`BBDCL_function _
201: | _,_,_,`BBDCL_var _
202: | _,_,_,`BBDCL_val _ -> x := i::!x
203: | _ -> ()
204: with Not_found -> ()
205: )
206: u;
207: let u = sort compare !x in
208: w (catmap "," si u);
209: w "; usedby: ";
210: let u = try Hashtbl.find usedby k with Not_found -> [] in
211: let x = ref [] in
212: iter (fun (i,_) -> if not (mem i !x) then x := i::!x) u;
213: let u = sort compare !x in
214: w (catmap "," si u);
215: w "\n"
216:
217: let print_call_report' syms bbdfns usage f =
218: let x = ref [] in
219: Hashtbl.iter
220: (fun k (id,_,sr,entry) ->
221: match entry with
222: | `BBDCL_procedure _
223: | `BBDCL_function _
224: | `BBDCL_var _
225: | `BBDCL_val _
226: -> x := k :: !x
227: | _ -> ()
228: )
229: bbdfns
230: ;
231: iter
232: (call_report syms bbdfns usage f)
233: (sort compare (!x))
234:
235: let print_call_report syms bbdfns f =
236: let usage = call_data syms bbdfns in
237: print_call_report' syms bbdfns usage f
238:
239: let expr_uses syms descend usage restrict e =
240: let u = ref IntSet.empty in
241: let add u i = u := IntSet.add i !u in
242: iter_tbexpr (add u) ignore ignore e;
243:
244:
245: (*
246: print_string ("Direct usage of expr " ^ sbe syms.dfns e ^ ": ");
247: IntSet.iter (fun i -> print_string (si i^" ")) !u;
248: print_endline "";
249:
250:
251: print_string ("Restrict = ");
252: IntSet.iter (fun i -> print_string (si i^" ")) restrict;
253: print_endline "";
254: *)
255:
256: let u = IntSet.fold
257: (fun i cls -> IntSet.union cls (
258: let cl = child_use_closure descend usage i in
259: (*
260: print_string ("Closure of " ^ si i ^ " is: ");
261: IntSet.iter (fun i -> print_string (si i ^ " ")) cl;
262: print_endline "";
263: *)
264: cl
265: ))
266: !u
267: !u
268: in let u = IntSet.inter restrict u in
269: (*
270: print_string ("Restricted usage of expr " ^ sbe syms.dfns e ^ ": ");
271: IntSet.iter (fun i -> print_string (si i^" ")) u;
272: print_endline "";
273: *)
274: u
275:
276: