1: # 63 "./lpsrc/flx_use.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:
18:
19: (* These routines find the absolute use closure of a symbol,
20: in particular they include variables which are initialised
21: but never used: these routine are intended to be used
22: to extract all the bound symbol table entries required
23: to process a set of roots.
24:
25: Contrast with the 'Flx_call' usage routines, which
26: find some symbols which are useful, this excludes
27: types, and it excludes LHS vals and perhaps vars,
28: which are not used in some expression.
29:
30: It seems a pity these routines are almost identical
31: (and the lot gets repeated yet again in the instantiator,
32: and weakly in the 'useless call eliminator', we hope
33: to find a better code reuse solution.. for now,
34: remember to update all three sets of routines when
35: changing the data structures.
36:
37: *)
38:
39: let nop x = ()
40:
41: let rec uses_type syms used bbdfns count_inits (t:btypecode_t) =
42: let ut t = uses_type syms used bbdfns count_inits t in
43: match t with
44: | `BTYP_inst (i,ts)
45: ->
46: uses syms used bbdfns count_inits i; (* don't care on uses inits? *)
47: iter ut ts
48:
49: | `BTYP_type
50: ->
51: failwith "[uses_type] Unexpected metatype"
52:
53: | _ -> iter_btype ut t
54:
55: and uses_exes syms used bbdfns count_inits exes =
56: iter (uses_exe syms used bbdfns count_inits) exes
57:
58: and uses_exe syms used bbdfns count_inits (exe:bexe_t) =
59: (*
60: print_endline ("EXE=" ^ string_of_bexe syms.dfns 0 exe);
61: *)
62: let ue e = uses_tbexpr syms used bbdfns count_inits e in
63: let ui i = uses syms used bbdfns count_inits i in
64: let ut t = uses_type syms used bbdfns count_inits t in
65: match exe,count_inits with
66: | `BEXE_init (_,i,e),false -> ue e
67: | _ ->
68: iter_bexe ui ue ut nop nop exe
69:
70:
71: and uses_tbexpr syms used bbdfns count_inits ((e,t) as x) =
72: let ue e = uses_tbexpr syms used bbdfns count_inits e in
73: let ut t = uses_type syms used bbdfns count_inits t in
74: let ui i = uses syms used bbdfns count_inits i in
75:
76: (* already done in the iter .. *)
77: (*
78: ut t;
79: *)
80: (* use a MAP now *)
81: iter_tbexpr ui ignore ut x;
82:
83: and uses_production syms used bbdfns count_inits p =
84: let uses_symbol (_,nt) = match nt with
85: | `Nonterm ii -> iter (uses syms used bbdfns count_inits) ii
86: | `Term i -> () (* HACK! This is a union constructor name we need to 'use' the union type!! *)
87: in
88: iter uses_symbol p
89:
90: and faulty_req syms i =
91: match Hashtbl.find syms.dfns i with {id=id; sr=sr } ->
92: clierr sr (id ^ " is used but has unsatisfied requirement")
93:
94: and uses syms used bbdfns count_inits i =
95: let ui i = uses syms used bbdfns count_inits i in
96: let ut t = uses_type syms used bbdfns count_inits t in
97: let rq reqs =
98: let ur (j,ts) =
99: if j = 0 then
100: faulty_req syms i
101: else begin ui j; iter ut ts end
102: in
103: iter ur reqs
104: in
105: let ux x = uses_exes syms used bbdfns count_inits x in
106: let ue e = uses_tbexpr syms used bbdfns count_inits e in
107: if not (IntSet.mem i !used) then
108: begin
109: match
110: try Some (Hashtbl.find bbdfns i)
111: with Not_found -> None
112: with
113: | Some (id,_,_,bbdcl) ->
114: used := IntSet.add i !used;
115: begin match bbdcl with
116: | `BBDCL_function (props,_,(ps,traint),ret,exes) ->
117: iter (fun (_,(i,t)) -> ui i; ut t) ps;
118: ut ret;
119: ux exes
120:
121: | `BBDCL_procedure (props,_,(ps,traint), exes) ->
122: iter (fun (_,(i,t)) -> ui i; ut t) ps;
123: ux exes
124:
125: | `BBDCL_glr (_,_,t,(p,e)) ->
126: ut t; ux e;
127: uses_production syms used bbdfns count_inits p
128:
129: | `BBDCL_regmatch (_,_,(ps,traint),t,(_,_,h,_)) ->
130: ut t; Hashtbl.iter (fun _ e -> ue e) h;
131: iter (fun (_,(i,t)) -> ui i; ut t) ps;
132:
133: | `BBDCL_reglex (_,_,(ps,traint),i,t,(_,_,h,_)) ->
134: ut t; Hashtbl.iter (fun _ e -> ue e) h;
135: iter (fun (_,(i,t)) -> ui i; ut t) ps;
136: ui i
137:
138: | `BBDCL_union (_,ps)
139: -> ()
140:
141: (* types of variant arguments are only used if constructed
142: .. OR .. matched against ??
143: *)
144:
145: | `BBDCL_struct (_,ps)
146: | `BBDCL_cstruct (_,ps)
147: ->
148: iter ut (map snd ps)
149:
150: | `BBDCL_class _ -> ()
151:
152: | `BBDCL_cclass (_,mems) -> ()
153:
154: | `BBDCL_val (_,t)
155: | `BBDCL_var (_,t)
156: | `BBDCL_tmp (_,t) -> ut t
157:
158: | `BBDCL_const (_,t,_,reqs) -> ut t; rq reqs
159: | `BBDCL_fun (_,_,ps, ret, _,reqs,_) -> iter ut ps; ut ret; rq reqs
160:
161: | `BBDCL_callback (_,_,ps_cf, ps_c, _, ret, reqs,_) ->
162: iter ut ps_cf;
163: iter ut ps_c;
164: ut ret; rq reqs
165:
166: | `BBDCL_proc (_,_,ps, _, reqs) -> iter ut ps; rq reqs
167:
168: | `BBDCL_abs (_,_,_,reqs) -> rq reqs
169: | `BBDCL_insert (_,s,ikind,reqs) -> rq reqs
170: | `BBDCL_nonconst_ctor (_,_,unt,_,ct) ->
171: ut unt; ut ct
172:
173: end
174: | None ->
175: let id =
176: try match Hashtbl.find syms.dfns i with {id=id} -> id
177: with Not_found -> "not found in unbound symbol table"
178: in
179: failwith
180: (
181: "[Flx_use.uses] Cannot find bound defn for " ^ id ^ "<"^si i ^ ">"
182: )
183: end
184:
185: let find_roots syms bbdfns
186: (root:bid_t)
187: (bifaces:biface_t list)
188: =
189:
190: (* make a list of the root and all exported functions,
191: add exported types and components thereof into the used
192: set now too
193: *)
194: let roots = ref (IntSet.singleton root) in
195: iter
196: (function
197: | `BIFACE_export_fun (_,x,_) -> roots := IntSet.add x !roots
198: | `BIFACE_export_type (_,t,_) ->
199: uses_type syms roots bbdfns true t
200: )
201: bifaces
202: ;
203: syms.roots := !roots
204:
205: let cal_use_closure syms bbdfns (count_inits:bool) =
206: let u = ref IntSet.empty in
207: let v : IntSet.t = !(syms.roots) in
208: let v = ref v in
209:
210: let add j =
211: if not (IntSet.mem j !u) then
212: begin
213: (*
214: print_endline ("Scanning " ^ si j);
215: *)
216: u:= IntSet.add j !u;
217: uses syms v bbdfns count_inits j
218: end
219: in
220: while not (IntSet.is_empty !v) do
221: let j = IntSet.choose !v in
222: v := IntSet.remove j !v;
223: add j
224: done;
225: !u
226:
227: let full_use_closure syms bbdfns = cal_use_closure syms bbdfns true
228:
229: let copy_used syms bbdfns =
230: let h = Hashtbl.create 97 in
231: let u = full_use_closure syms bbdfns in
232: IntSet.iter
233: begin fun i ->
234: (* print_endline ("Copying " ^ si i); *)
235: Hashtbl.add h i (Hashtbl.find bbdfns i)
236: end
237: u;
238: h
239:
1: # 28 "./lpsrc/flx_tailit.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_call
20:
21: let isvariable bbdfns i =
22: let id,_,_,entry = Hashtbl.find bbdfns i in match entry with
23: | `BBDCL_var _ | `BBDCL_val _ ->
24: (* print_endline ("Var/Val " ^ id ^ "<" ^ si i ^">"); *) true
25: | _ -> false
26:
27: let isfun bbdfns i =
28: let id,_,_,entry = Hashtbl.find bbdfns i in match entry with
29: | `BBDCL_function _ | `BBDCL_procedure _ ->
30: (*print_endline ("Fun/proc " ^ id ^ "<" ^ si i ^">"); *) true
31: | _ -> false
32:
33: let add_xclosure syms cls e =
34: (*
35: print_endline ("chk cls for " ^ sbe syms.dfns e);
36: *)
37: match e with
38: | `BEXPR_closure (i,ts),t -> cls := IntSet.add i !cls
39: | _ -> ()
40:
41: let ident x = x
42:
43: (* WARNING!! closure here has TWO meanings: a BEXPR_closure,
44: and ALSO the setwise closure of all such explicit closure
45: terms ..
46: *)
47:
48: let expr_find_xclosures syms cls e =
49: iter_tbexpr ignore (add_xclosure syms cls) ignore e
50:
51: let exe_find_xclosure syms cls exe =
52: iter_bexe ignore (expr_find_xclosures syms cls) ignore ignore ignore exe
53:
54: let exes_find_xclosure syms cls exes =
55: iter (exe_find_xclosure syms cls) exes
56:
57: let exes_get_xclosures syms exes =
58: let cls = ref IntSet.empty in
59: exes_find_xclosure syms cls exes;
60: !cls
61:
62: let function_find_xclosure syms cls bbdfns i =
63: let _,_,_,entry = Hashtbl.find bbdfns i in
64: let exes =
65: match entry with
66: | `BBDCL_procedure (_,_,_,exes)
67: | `BBDCL_function (_,_,_,_,exes) -> exes
68: | _ -> []
69: in
70: (*
71: print_endline ("ROUTINE " ^ si i);
72: iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
73: *)
74: exes_find_xclosure syms cls exes
75:
76: let functions_find_xclosures syms cls bbdfns ii =
77: IntSet.iter
78: (function_find_xclosure syms cls bbdfns)
79: ii
80:
81: let tailit syms (uses,child_map,bbdfns) this sr ps vs exes : bexe_t list =
82: let ts' = map (fun (_,i) -> `BTYP_var (i,`BTYP_type)) vs in
83: let pset = fold_left (fun s (_,(i,_))-> IntSet.add i s) IntSet.empty ps in
84: let parameters = ref [] in
85: let descend = descendants child_map this in
86: let children = try Hashtbl.find child_map this with Not_found -> [] in
87: let can_loop () =
88: let varlist = filter (isvariable bbdfns) children in
89: let funset = IntSet.filter (isfun bbdfns) descend in
90:
91: (*
92: print_endline ("Procedure has " ^ si (length varlist) ^ " variables");
93: print_endline ("Procedure has " ^ si (IntSet.cardinal funset) ^ " child funcs");
94: *)
95:
96: let cls = ref IntSet.empty in
97: functions_find_xclosures syms cls bbdfns funset;
98: (* THIS FUNCTION IS BEING INLINED .. WE CANNOT LOOKUP ITS EXES!! *)
99: exes_find_xclosure syms cls exes;
100: (*
101: print_endline ("Total xclosures " ^ si (IntSet.cardinal !cls));
102: *)
103: let kidcls = IntSet.inter !cls funset in
104: (*
105: print_endline ("Kid xclosures " ^ si (IntSet.cardinal kidcls));
106: *)
107: try
108: IntSet.iter
109: (fun i ->
110: let usage = Hashtbl.find uses i in
111: iter
112: (fun j ->
113: let usesj = mem_assoc j usage in
114: (*
115: if usesj then
116: print_endline (si i ^ " uses var " ^ si j)
117: ;
118: *)
119: if usesj then raise Not_found;
120: )
121: varlist
122: )
123: kidcls
124: ;
125: true
126: with
127: | Not_found -> false
128: in
129: let jump_done = ref false in
130: let lc = !(syms.counter) in incr (syms.counter);
131: let start_label = "start_" ^ si lc in
132:
133: (* note reverse order *)
134: (* Weirdly, this works for BOTH tail calls
135: and tail applies
136: *)
137: let cal_tail_call e =
138: match length ps with
139: | 0 ->
140: [
141: `BEXE_goto (sr,start_label);
142: `BEXE_comment (sr,"tail rec call (0)")
143: ]
144: | 1 ->
145: let (_,(k,_)) = hd ps in
146: [
147: `BEXE_goto (sr,start_label);
148: `BEXE_init (sr,k,e);
149: `BEXE_comment (sr,"tail rec call (1)")
150: ]
151: | _ ->
152: begin match e with
153: | `BEXPR_tuple ls,_ ->
154: (*
155: print_endline ("TUPLE ASSGN " ^ sbe syms.dfns e);
156: *)
157: (* Parallel Assignment algorithm.
158: Given a set of assignments, xi = ei,
159: we need a sequence of assignments of xi, ei, tj,
160: where tj are fresh variables, xi on left, ei on
161: right, and tj on either side, such that no RHS
162: term depends on a prior LHS term.
163:
164: A pair x1 = e1, x2 = e2 which are mutually dependent
165: can always by resolved as
166:
167: t1 = e1; x2 = e2; x1 = t1
168:
169: Here e1 doesn't depend on a prior term, vaccuously,
170: e2 can't depend on t1 since it is fresh, and
171: t1 can't depend on anything, since it just a fresh variable
172:
173: Let's start by taking the equations, and making
174: two lists -- a head list and a tail list.
175: Head assignments are done first, tails last,
176: the head list is in reverse order.
177:
178: Any equations setting variables no one depends on
179: can be moved into the head list, they can safely
180: be done first.
181:
182: Any equations whose RHS depend on nothing are
183: moved into the tail list, its safe to do them last.
184:
185: Any dependencies on variables set by equations
186: moved into the tail list can now be removed
187: from the remaining equations, since it is determined
188: now that these variables will be changed after
189: any of the remaining assignments are one.
190:
191: Repeat until the set of remaining equations is fixed.
192:
193: We can now pick (somehow!!) an equation, and break
194: it into two using a fresh temporary. The temporary
195: assignment goes on the head list, the variable
196: assignment from the temporary on the tail list,
197: and as above, any dependencies on the variable
198: can now be removed from the remaining equations.
199:
200: Repeat everything until the set of remaining
201: equations is empty, the result is the reverse
202: of the heap list plus the tail list.
203:
204: This process is certain to terminate, since
205: each outer step removes one equation,
206: and it is certain to be correct (obvious).
207:
208: What is NOT clear is that the result is minimal.
209: And it is NOT clear how to best 'choose' which
210: equation to split.
211:
212:
213: *)
214: assert (length ls = length ps);
215: let pinits =
216: map2
217: (fun (name,(i,t)) e ->
218: i,(name,t,e,expr_uses syms descend uses pset e)
219: )
220: ps ls
221: in
222: (* strip trivial assignments like x = x *)
223: let pinits =
224: filter
225: (fun (i,(name,t,e,u)) ->
226: match e with
227: | `BEXPR_name (j,_),_ when i = j -> false
228: | _ -> true
229: )
230: pinits
231: in
232: let fixdeps pinits =
233: let vars = fold_left (fun s (i,_) -> IntSet.add i s) IntSet.empty pinits in
234: map
235: (fun (i,(name,t,e,u)) ->
236: let u = IntSet.remove i (IntSet.inter u vars) in
237: i,(name,t,e,u)
238: )
239: pinits
240: in
241: (*
242: iter
243: (fun (i,(name,t,e,u)) ->
244: print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e);
245: print_string " Depends: ";
246: IntSet.iter (fun i -> print_string (si i ^ ", ")) u;
247: print_endline "";
248: )
249: pinits;
250: *)
251: (* this function measures if the expression assigning i
252: depends on the old value of j
253: *)
254: let depend pinits i j =
255: let u = match assoc i pinits with _,_,_,u -> u in
256: IntSet.mem j u
257: in
258: (* return true if an assignment in inits depends on j *)
259: let used j inits =
260: fold_left (fun r (i,_)-> r or depend inits i j) false inits
261: in
262: let rec aux ((head, middle, tail) as arg) = function
263: | [] -> arg
264: | (i,(name,ty,e,u)) as h :: ta ->
265: if IntSet.cardinal u = 0 then
266: aux (head,middle,h::tail) ta
267: else if not (used i (middle @ ta)) then
268: aux (h::head, middle, tail) ta
269: else
270: aux (head,h::middle,tail) ta
271: in
272:
273: let printem (h,m,t) =
274: print_endline "HEAD:";
275: iter
276: (fun (i,(name,t,e,u)) ->
277: print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e)
278: )
279: h;
280:
281: print_endline "MIDDLE:";
282: iter
283: (fun (i,(name,t,e,u)) ->
284: print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e)
285: )
286: m;
287:
288: print_endline "TAIL:";
289: iter
290: (fun (i,(name,t,e,u)) ->
291: print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e)
292: )
293: t
294: in
295:
296: let rec aux2 (hh,mm,tt) =
297: let h,m,t = aux ([],[],[]) (fixdeps mm) in
298: (* printem (h,m,t); *)
299: (* reached a fixpoint? *)
300: if length h = 0 && length t = 0 then hh,m,tt (* m = mm *)
301: else begin
302: (*
303: print_endline "Recursing on MIDDLE";
304: *)
305: aux2 (h @ hh, m, t @ tt)
306: end
307: in
308: let tmplist = ref [] in
309: let rec aux3 (hh,mm,tt) =
310: let h,m,t = aux2 (hh,mm,tt) in
311: (*
312: print_endline "SPLIT STEP result:";
313: printem(h,m,t);
314: *)
315: match m with
316: | [] -> rev h @ t
317: | [_] -> assert false
318: | (i,(name,ty,e,u)) :: ta ->
319: let k = !(syms.counter) in incr syms.counter;
320: let name2 = "_tmp_" ^ name in
321: parameters := (ty,k) :: !parameters;
322: tmplist := k :: !tmplist;
323: let h' = k,(name2,ty,e,IntSet.empty) in
324: let e' = `BEXPR_name (k,ts'),ty in
325: let t' = i,(name,ty,e',IntSet.empty) in
326: aux3 (h' :: h, ta, t' :: t)
327: in
328: let m = aux3 ([],pinits,[]) in
329: (*
330: print_endline "FINAL SPLIT UP:";
331: iter
332: (fun (i,(name,t,e,u)) ->
333: print_endline ("ASG " ^ name ^ "<"^si i ^ "> = " ^ sbe syms.dfns e)
334: )
335: m;
336: *)
337: let result = ref [] in
338: result := `BEXE_comment (sr,"tail rec call (3)") :: !result;
339: iter
340: (fun (i,(name,ty,e,_)) ->
341: if mem i !tmplist then
342: result := `BEXE_begin :: !result;
343: result := `BEXE_init (sr,i,e) :: !result;
344: )
345: m;
346: while length !tmplist > 0 do
347: result := `BEXE_end :: !result;
348: tmplist := tl !tmplist
349: done;
350: result := `BEXE_goto (sr,start_label) :: !result;
351: (*
352: print_endline "Tail opt code is:";
353: iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x) ) (rev !result);
354: *)
355: !result
356:
357: | _ ->
358: print_endline "NON TUPLE TAIL CALL";
359: let t = snd e in
360: let pix =
361: try assoc t !parameters
362: with Not_found ->
363: let pix = !(syms.counter) in incr syms.counter;
364: parameters := (t,pix) :: !parameters;
365: pix
366: in
367: let p = `BEXPR_name (pix,ts'),t in
368: let n = ref 0 in
369: let param_decode =
370: map
371: (fun (_,(ix,prjt)) ->
372: let prj = reduce_tbexpr bbdfns (`BEXPR_get_n (!n,p),prjt) in
373: incr n;
374: `BEXE_init (sr,ix,prj)
375: )
376: ps
377: in
378: [
379: `BEXE_goto (sr,start_label);
380: ]
381: @
382: param_decode
383: @
384: [
385: `BEXE_init (sr,pix,e);
386: `BEXE_comment (sr,"tail rec call (2)")
387: ]
388: end
389: in
390: let rec aux tail res = match tail with
391: | (`BEXE_call_direct (sr,i,ts,a)) as x :: tail
392: when (i,ts)=(this,ts') && Flx_cflow.tailable exes [] tail
393: ->
394: if can_loop ()
395: then begin
396: (*
397: print_endline ("--> Tail rec call optimised " ^ si this);
398: *)
399: jump_done := true;
400: let res = cal_tail_call a @ res
401: in aux tail res
402: end else begin
403: (*
404: print_endline ("--> Tail rec call NOT optimised " ^ si this);
405: *)
406: aux tail (x::res)
407: end
408:
409: | `BEXE_fun_return (sr,(`BEXPR_apply_direct(i,ts,a),_)) :: tail
410: when (i,ts)=(this,ts')
411: ->
412: (*
413: print_endline ("--> Tail rec apply " ^ si this);
414: *)
415: jump_done := true;
416: let res = cal_tail_call a @ res
417: in aux tail res
418:
419: | (`BEXE_call_direct (sr,i,ts,a)) as x :: tail ->
420: (*
421: print_endline ("Untailed call " ^ si i ^ "["^catmap "," (sbt syms.dfns) ts^"]");
422: print_endline ("This = " ^ si this);
423: print_endline ("ts'=" ^"["^catmap "," (sbt syms.dfns) ts'^"]");
424: print_endline "TAIL=";
425: iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) tail;
426: print_endline "-- end of tail --";
427: *)
428: aux tail (x::res)
429:
430: | [] -> rev res (* forward order *)
431: | h :: t -> aux t (h::res)
432: in
433: let exes = aux exes [] in
434:
435: (* instantiate any parameter temporaries *)
436: iter
437: (fun (paramtype, parameter) ->
438: let entry = `BBDCL_tmp (vs,paramtype) in
439: let kids =
440: try Hashtbl.find child_map this
441: with Not_found -> []
442: in
443: Hashtbl.replace child_map this (parameter::kids);
444: let id = "_trp_" ^ si parameter in
445: Hashtbl.add bbdfns parameter (id,Some this,sr,entry);
446: )
447: !parameters
448: ;
449: (* return with posssible label at start *)
450: let exes =
451: if !jump_done
452: then `BEXE_label (sr,start_label) :: exes
453: else exes
454: in
455: (*
456: print_endline ("Tailed exes = ");
457: iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
458: *)
459: exes
460: