1: # 53 "./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:
14: (* NOTE: THIS CODE LARGELY DUPLICATES CODE IN flx_use.ml *)
15:
16: type usage_table_t = (bid_t, (bid_t * range_srcref) list) Hashtbl.t
17: type usage_t = usage_table_t * usage_table_t
18:
19: let add (h:usage_table_t) k j sr =
20: (*
21: print_endline ("Adding use of " ^ si j ^ " in " ^ si k);
22: *)
23: Hashtbl.replace h k
24: (
25: (j,sr)
26: ::
27: (
28: try Hashtbl.find h k
29: with Not_found -> []
30: )
31: )
32:
33: let rec uses_type h k sr t =
34: let ut t = uses_type h k sr t in
35: match t with
36: | `BTYP_inst (i,ts)
37: ->
38: add h k i sr;
39: iter ut ts
40:
41: | _ -> iter_btype ut t
42:
43:
44:
45: let faulty_req syms i =
46: match Hashtbl.find syms.dfns i with {id=id; sr=sr } ->
47: clierr sr (id ^ " is used but has unsatisfied requirement")
48:
49:
50: let rec process_expr h k sr e =
51: let ue e = process_expr h k sr e in
52: let ui i = add h k i sr in
53: let ut t = uses_type h k sr t in
54: iter_tbexpr ui ignore ut e
55:
56: and cal_exe_usage syms h k exe =
57: (*
58: print_endline ("Checking uses in " ^ si k ^ ", exe: " ^ string_of_bexe syms.dfns 2 exe);
59: *)
60: let sr = src_of_bexe exe in
61: let ue e = process_expr h k sr e in
62: let ui i = add h k i sr in
63: let ut t = uses_type h k sr t in
64: iter_bexe ui ue ut ignore ignore exe
65:
66: let cal_expr_usage syms h k sr e =
67: process_expr h k sr e
68:
69: let uses_production h k sr p =
70: let uses_symbol (_,nt) = match nt with
71: | `Nonterm jj -> iter (fun i -> add h k i sr) jj
72: | `Term _ -> () (* HACK! This is a union constructor name we need to 'use' the union type!! *)
73: in
74: iter uses_symbol p
75:
76: let cal_param_usage syms uses sr parent {pindex=child;ptyp=t} =
77: uses_type uses parent sr t;
78: add uses parent child sr
79:
80: let call_data syms (bbdfns:fully_bound_symbol_table_t):usage_t =
81: let uses = Hashtbl.create 97 in
82: let usedby = Hashtbl.create 97 in
83: let usage = uses,usedby in
84: let cal_req_usage sr parent reqs =
85: let ur (j,ts) =
86: if j = 0 then faulty_req syms parent
87: else add uses parent j sr
88: in
89: iter ur reqs
90: in
91: Hashtbl.iter
92: (fun k (_,_,sr,entry) ->
93: let ut t = uses_type uses k sr t in
94:
95: match entry with
96: | `BBDCL_typeclass _ -> ()
97:
98: | `BBDCL_procedure (_,_,(ps,_),exes)
99: | `BBDCL_function (_,_,(ps,_),_,exes) ->
100: iter (cal_param_usage syms uses sr k) ps;
101: iter (cal_exe_usage syms uses k) exes
102:
103: | `BBDCL_glr (_,_,_,(p,exes)) ->
104: iter (cal_exe_usage syms uses k) exes;
105: uses_production uses k sr p
106:
107: | `BBDCL_regmatch (_,_,(ps,_),_,(_,_,h,_))
108: | `BBDCL_reglex (_,_,(ps,_),_,_,(_,_,h,_)) ->
109: iter (cal_param_usage syms uses sr k) ps;
110: Hashtbl.iter (fun _ e -> process_expr uses k sr e) h
111:
112: | `BBDCL_newtype (_,t) -> ut t
113: | `BBDCL_abs (_,_,_,reqs) -> cal_req_usage sr k reqs
114: | `BBDCL_const (_,t,_,reqs) -> cal_req_usage sr k reqs
115: | `BBDCL_proc (_,_,ps,_, reqs) -> cal_req_usage sr k reqs; iter ut ps
116: | `BBDCL_fun (_,_,ps,ret,_, reqs,_) -> cal_req_usage sr k reqs; iter ut ps; ut ret
117: | `BBDCL_insert (_,_,_,reqs) -> cal_req_usage sr k reqs
118: | `BBDCL_instance (_,_,cons,i,ts) ->
119: (* we dont add the type constraint, since it
120: is only used for instance selection
121: *)
122: add uses k i sr; iter ut ts
123:
124: | `BBDCL_nonconst_ctor (_,_,unt,_,ct, evs, etraint) ->
125: ut unt; ut ct
126:
127: | `BBDCL_union _ -> ()
128:
129: | `BBDCL_struct (_,ps)
130: | `BBDCL_cstruct (_,ps) ->
131: iter ut (map snd ps)
132:
133: | `BBDCL_class _ -> ()
134: | `BBDCL_cclass _ -> ()
135: | `BBDCL_val (_,t)
136: | `BBDCL_var (_,t)
137: | `BBDCL_tmp (_,t) -> ut t
138: | `BBDCL_ref (_,t) -> ut (`BTYP_pointer t)
139: | `BBDCL_callback (_,_,ps_cf, ps_c, _, ret, reqs,_) ->
140: iter ut ps_cf;
141: iter ut ps_c;
142: ut ret; cal_req_usage sr k reqs
143:
144: )
145: bbdfns
146: ;
147: (* invert uses table to get usedby table *)
148: Hashtbl.iter
149: (fun k ls ->
150: iter
151: (fun (i,sr) -> add usedby i k sr)
152: ls
153: )
154: uses
155: ;
156: usage
157:
158: (* closure of i, excluding i unless it is recursive! *)
159: let cls h i =
160: let c = ref IntSet.empty in
161: let rec add j =
162: if not (IntSet.mem j !c) 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: let is_recursive_call h caller callee = IntSet.mem caller (cls h callee)
175: let is_recursive h i = is_recursive_call h i i
176:
177: let use_closure h i = cls h i
178:
179: (* this calculates the use closure of i, eliminating recursive
180: calls to the base function by restricting references
181: to some set k. Note this means the usage of k is also
182: not included.
183:
184: If k is set to the children of some function f,
185: then this routine will not report usage of any
186: variables in f via calls to f, only direct
187: uses in some child which is called; in particular
188: calls to outside the child tree of f are not tracked
189: since they can't call any children of f,
190: so they can only use them via a call to f.
191: This would spawn a new stack frame, and so
192: refer to different copies of variables.
193:
194: This routine is used to find which variables
195: in f an expression in f can use via a call to a child.
196:
197: OUCH OUCH OUCH. I THINK THIS IDEA MUST BE BUGGED!
198:
199: Here's the problem. Given
200:
201: fun A(){
202: fun B { fun C() {} return C; }
203: fun D(f) { f 1; }
204: D (B());
205: }
206:
207: function B is returning a closure of C,
208: which is being passed into D and called.
209: Note D cannot see the function C.
210:
211: The inliner should handle this correctly:
212: B is inlined to return a *clone* C' of C which
213: is nested in A, then D is inlined, resulting
214: in the call C' 1 (which can now be inlined too).
215:
216: The problem is that the assumption "calls outside
217: the child tree of f are not tracked since they can't
218: call any children of f" is wrong. A call outside
219: the tree can still execute something inside
220: the tree via a closure .. however how does the
221: closure get out .. it has to be 'made' by someon
222: who can see it ..
223:
224: *)
225:
226: let child_use_closure k h i =
227: let c = ref IntSet.empty in
228: let rec add j =
229: if not (IntSet.mem j !c) && IntSet.mem j k then
230: begin
231: c := IntSet.add j !c;
232: let x = try Hashtbl.find h j with Not_found -> [] in
233: iter (fun (j,_) -> add j) x
234: end
235: in
236: let x = try Hashtbl.find h i with Not_found -> [] in
237: iter (fun (j,_) -> add j) x
238: ;
239: !c
240:
241:
242: let call_report syms bbdfns (uses,usedby) f k =
243: let si = string_of_int in
244: let catmap = Flx_util.catmap in
245: let w s = output_string f s in
246: let isr = is_recursive uses k in
247: let id,_,sr,entry = Hashtbl.find bbdfns k in
248: w (si k ^ ": ");
249: w (if isr then "recursive " else "");
250: w
251: begin match entry with
252: | `BBDCL_function _ -> "fun "
253: | `BBDCL_procedure _ -> "proc "
254: | `BBDCL_var _ -> "var "
255: | `BBDCL_val _ -> "val "
256: | _ -> assert false
257: end
258: ;
259: w (id ^ " uses: ");
260: let u = try Hashtbl.find uses k with Not_found -> [] in
261: let x = ref [] in
262: iter
263: (fun (i,_) ->
264: if not (mem i !x) then
265: try match Hashtbl.find bbdfns i with
266: | _,_,_,`BBDCL_procedure _
267: | _,_,_,`BBDCL_function _
268: | _,_,_,`BBDCL_var _
269: | _,_,_,`BBDCL_val _ -> x := i::!x
270: | _ -> ()
271: with Not_found -> ()
272: )
273: u;
274: let u = sort compare !x in
275: w (catmap "," si u);
276: w "; usedby: ";
277: let u = try Hashtbl.find usedby k with Not_found -> [] in
278: let x = ref [] in
279: iter (fun (i,_) -> if not (mem i !x) then x := i::!x) u;
280: let u = sort compare !x in
281: w (catmap "," si u);
282: w "\n"
283:
284: let print_call_report' syms bbdfns usage f =
285: let x = ref [] in
286: Hashtbl.iter
287: (fun k (id,_,sr,entry) ->
288: match entry with
289: | `BBDCL_procedure _
290: | `BBDCL_function _
291: | `BBDCL_var _
292: | `BBDCL_val _
293: -> x := k :: !x
294: | _ -> ()
295: )
296: bbdfns
297: ;
298: iter
299: (call_report syms bbdfns usage f)
300: (sort compare (!x))
301:
302: let print_call_report syms bbdfns f =
303: let usage = call_data syms bbdfns in
304: print_call_report' syms bbdfns usage f
305:
306: let expr_uses syms descend usage restrict e =
307: let u = ref IntSet.empty in
308: let add u i = u := IntSet.add i !u in
309: iter_tbexpr (add u) ignore ignore e;
310:
311:
312: (*
313: print_string ("Direct usage of expr " ^ sbe syms.dfns e ^ ": ");
314: IntSet.iter (fun i -> print_string (si i^" ")) !u;
315: print_endline "";
316:
317:
318: print_string ("Restrict = ");
319: IntSet.iter (fun i -> print_string (si i^" ")) restrict;
320: print_endline "";
321: *)
322:
323: let u = IntSet.fold
324: (fun i cls -> IntSet.union cls (
325: let cl = child_use_closure descend usage i in
326: (*
327: print_string ("Closure of " ^ si i ^ " is: ");
328: IntSet.iter (fun i -> print_string (si i ^ " ")) cl;
329: print_endline "";
330: *)
331: cl
332: ))
333: !u
334: !u
335: in let u = IntSet.inter restrict u in
336: (*
337: print_string ("Restricted usage of expr " ^ sbe syms.dfns e ^ ": ");
338: IntSet.iter (fun i -> print_string (si i^" ")) u;
339: print_endline "";
340: *)
341: u
342:
343: