1: # 18 "./lpsrc/flx_mkcls.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_mtypes1
6: open Flx_mtypes2
7: open Flx_print
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_exceptions
15: open Flx_use
16:
17: let gen_closure syms bbdfns i =
18: let j = !(syms.counter) in incr syms.counter;
19: let id,parent,sr,entry = Hashtbl.find bbdfns i in
20: match entry with
21: | `BBDCL_proc (props,vs,ps,c,reqs) ->
22: let arg_t =
23: match ps with | [t] -> t | ps -> `BTYP_tuple ps
24: in
25: let ts = map (fun (_,i) -> `BTYP_var (i,`BTYP_type)) vs in
26: let ps,a =
27: let n = !(syms.counter) in incr syms.counter;
28: let name = "_a" ^ si n in
29: let ventry = `BBDCL_val (vs,arg_t) in
30: Hashtbl.add bbdfns n (name,Some j,sr,ventry);
31: [name,(n,arg_t)],(`BEXPR_name (n,ts),arg_t)
32: in
33:
34: let exes : bexe_t list =
35: [
36: `BEXE_call_prim (sr,i,ts,a);
37: `BEXE_proc_return sr
38: ]
39: in
40: let entry = `BBDCL_procedure ([],vs,(ps,None),exes) in
41: Hashtbl.add bbdfns j (id,parent,sr,entry);
42: j
43:
44: | `BBDCL_fun (props,vs,ps,ret,c,reqs,_) ->
45: let ts = map (fun (_,i) -> `BTYP_var (i,`BTYP_type)) vs in
46: let arg_t =
47: match ps with | [t] -> t | ps -> `BTYP_tuple ps
48: in
49: let ps,a =
50: let n = !(syms.counter) in incr syms.counter;
51: let name = "_a" ^ si n in
52: let ventry = `BBDCL_val (vs,arg_t) in
53: Hashtbl.add bbdfns n (name,Some j,sr,ventry);
54: [name,(n,arg_t)],(`BEXPR_name (n,ts),arg_t)
55: in
56: let e = `BEXPR_apply_prim (i,ts,a),ret in
57: let exes : bexe_t list = [`BEXE_fun_return (sr,e)] in
58: let entry = `BBDCL_function ([],vs,(ps,None),ret,exes) in
59: Hashtbl.add bbdfns j (id,parent,sr,entry);
60: j
61:
62: | _ -> assert false
63:
64:
65: let mkcls syms bbdfns all_closures i ts =
66: let j =
67: try Hashtbl.find syms.wrappers i
68: with Not_found ->
69: let j = gen_closure syms bbdfns i in
70: Hashtbl.add syms.wrappers i j;
71: j
72: in
73: all_closures := IntSet.add j !all_closures;
74: `BEXPR_closure (j,ts)
75:
76: let check_prim syms bbdfns all_closures i ts =
77: let _,_,_,entry = Hashtbl.find bbdfns i in
78: match entry with
79: | `BBDCL_proc _
80: | `BBDCL_fun _ ->
81: mkcls syms bbdfns all_closures i ts
82: | _ ->
83: all_closures := IntSet.add i !all_closures;
84: `BEXPR_closure (i,ts)
85:
86: let idt t = t
87:
88: let ident x = x
89:
90: let rec adj_cls syms bbdfns all_closures e =
91: let adj e = adj_cls syms bbdfns all_closures e in
92: match Flx_maps.map_tbexpr ident adj idt e with
93: | `BEXPR_closure (i,ts),t ->
94: check_prim syms bbdfns all_closures i ts,t
95:
96: (* Direct calls to non-stacked functions require heap
97: but not a clone ..
98: *)
99: | `BEXPR_apply_direct (i,ts,a),t as x ->
100: all_closures := IntSet.add i !all_closures;
101: x
102:
103: (* Class method -- ASSUMED NOT A PRIMITIVE -- seem to require
104: heap closures: not sure why this should be. They cannot
105: be inlined into their parent at the moment, since it is a class,
106: and any 'inlined' version would be an actual C++ class method.
107: Which would also be a kind of stack call. In any case
108: we cannot optimise this yet.
109: *)
110: | `BEXPR_method_closure (_,i,_),_ as x ->
111: all_closures := IntSet.add i !all_closures;
112: x
113:
114: (* HUM .. *)
115: (*
116: | `BEXPR_parse (_,prds),_ as x ->
117: iter (fun i -> all_closures := IntSet.add i !all_closures) prds;
118: x
119: *)
120:
121: | x -> x
122:
123:
124: let process_exe syms bbdfns all_closures (exe : bexe_t) : bexe_t =
125: let ue e = adj_cls syms bbdfns all_closures e in
126: match exe with
127: | `BEXE_axiom_check _ -> assert false
128: | `BEXE_call_prim (sr,i,ts,e2) -> `BEXE_call_prim (sr,i,ts, ue e2)
129:
130: | `BEXE_call_direct (sr,i,ts,e2) ->
131: all_closures := IntSet.add i !all_closures;
132: `BEXE_call_direct (sr,i,ts, ue e2)
133:
134: | `BEXE_call_method_direct (sr,e1,i,ts,e2) ->
135: all_closures := IntSet.add i !all_closures;
136: `BEXE_call_method_direct (sr,ue e1,i,ts, ue e2)
137:
138: | `BEXE_call_method_stack (sr,e1,i,ts,e2) ->
139: (* stack calls do use closures -- but not heap allocated ones *)
140: `BEXE_call_method_stack (sr,ue e1,i,ts, ue e2)
141:
142:
143: | `BEXE_jump_direct (sr,i,ts,e2) ->
144: all_closures := IntSet.add i !all_closures;
145: `BEXE_jump_direct (sr,i,ts, ue e2)
146:
147: | `BEXE_call_stack (sr,i,ts,e2) ->
148: (* stack calls do use closures -- but not heap allocated ones *)
149: `BEXE_call_stack (sr,i,ts, ue e2)
150:
151: | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2) ->
152: all_closures := IntSet.add i2 !all_closures;
153: all_closures := IntSet.add i3 !all_closures;
154: `BEXE_apply_ctor(sr,i1,i2,ts,i3,ue e2)
155:
156: | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2) ->
157: all_closures := IntSet.add i2 !all_closures;
158: `BEXE_apply_ctor_stack(sr,i1,i2,ts,i3,ue e2)
159:
160: | `BEXE_call (sr,e1,e2) -> `BEXE_call (sr,ue e1, ue e2)
161: | `BEXE_jump (sr,e1,e2) -> `BEXE_jump (sr,ue e1, ue e2)
162:
163: | `BEXE_loop (sr,i,e) -> `BEXE_loop (sr,i, ue e)
164: | `BEXE_ifgoto (sr,e,l) -> `BEXE_ifgoto (sr, ue e,l)
165: | `BEXE_ifnotgoto (sr,e,l) -> `BEXE_ifnotgoto (sr, ue e,l)
166: | `BEXE_fun_return (sr,e) -> `BEXE_fun_return (sr,ue e)
167:
168: | `BEXE_init (sr,i,e) -> `BEXE_init (sr,i,ue e)
169: | `BEXE_assign (sr,e1,e2) -> `BEXE_assign (sr, ue e1, ue e2)
170: | `BEXE_assert (sr,e) -> `BEXE_assert (sr, ue e)
171: | `BEXE_assert2 (sr,sr2,e) -> `BEXE_assert2 (sr, sr2,ue e)
172:
173: | `BEXE_svc (sr,i) -> exe
174:
175: | `BEXE_label _
176: | `BEXE_halt _
177: | `BEXE_goto _
178: | `BEXE_code _
179: | `BEXE_nonreturn_code _
180: | `BEXE_comment _
181: | `BEXE_nop _
182: | `BEXE_proc_return _
183: | `BEXE_begin
184: | `BEXE_end
185: -> exe
186:
187: let process_exes syms bbdfns all_closures exes =
188: map (process_exe syms bbdfns all_closures) exes
189:
190: let process_entry syms bbdfns all_closures i =
191: let ue e = adj_cls syms bbdfns all_closures e in
192: let id,parent,sr,entry = Hashtbl.find bbdfns i in
193: match entry with
194: | `BBDCL_function (props,vs,ps,ret,exes) ->
195: let exes = process_exes syms bbdfns all_closures exes in
196: let entry = `BBDCL_function (props,vs,ps,ret,exes) in
197: Hashtbl.replace bbdfns i (id,parent,sr,entry)
198:
199: | `BBDCL_procedure (props,vs,ps,exes) ->
200: let exes = process_exes syms bbdfns all_closures exes in
201: let entry = `BBDCL_procedure (props,vs,ps,exes) in
202: Hashtbl.replace bbdfns i (id,parent,sr,entry)
203:
204: | `BBDCL_glr (props,vs,t,(p,exes)) ->
205: let exes = process_exes syms bbdfns all_closures exes in
206: let entry = `BBDCL_glr (props,vs,t,(p,exes)) in
207: Hashtbl.replace bbdfns i (id,parent,sr,entry)
208:
209: | `BBDCL_regmatch (props,vs,ps,t,(a,j,h,m)) ->
210: Hashtbl.iter (fun i e -> Hashtbl.replace h i (ue e)) h
211:
212: | `BBDCL_reglex (props,vs,ps,i,t,(a,j,h,m)) ->
213: Hashtbl.iter (fun i e -> Hashtbl.replace h i (ue e)) h
214:
215: | _ -> ()
216:
217: let set_closure bbdfns p i =
218: let id,parent,sr,entry = Hashtbl.find bbdfns i in
219: match entry with
220: | `BBDCL_function (props,vs,ps,ret,exes) ->
221: let entry = `BBDCL_function (p :: props,vs,ps,ret,exes) in
222: Hashtbl.replace bbdfns i (id,parent,sr,entry);
223:
224: | `BBDCL_procedure (props,vs,ps,exes) ->
225: let entry = `BBDCL_procedure (p :: props,vs,ps,exes) in
226: Hashtbl.replace bbdfns i (id,parent,sr,entry)
227:
228: | `BBDCL_regmatch (props,vs,ps,t,x) ->
229: let entry = `BBDCL_regmatch (p :: props, vs, ps, t, x) in
230: Hashtbl.replace bbdfns i (id,parent,sr,entry)
231:
232: | `BBDCL_reglex (props,vs,ps,le,t,x) ->
233: let entry = `BBDCL_reglex (p :: props, vs, ps, le, t, x) in
234: Hashtbl.replace bbdfns i (id,parent,sr,entry)
235:
236: | `BBDCL_glr (props, vs, t, x) ->
237: let entry = `BBDCL_glr (p :: props, vs, t, x) in
238: Hashtbl.replace bbdfns i (id,parent,sr,entry)
239:
240: | _ -> ()
241:
242: let make_closures syms bbdfns =
243: (*
244: let used = ref IntSet.empty in
245: let uses i = Flx_use.uses syms used bbdfns true i in
246: IntSet.iter uses !(syms.roots);
247: *)
248:
249: let all_closures = ref IntSet.empty in
250: let used = full_use_closure syms bbdfns in
251: IntSet.iter (process_entry syms bbdfns all_closures ) used;
252: (*
253: IntSet.iter (set_closure bbdfns `Heap_closure) (IntSet.union !all_closures !(syms.roots));
254: *)
255:
256: (* Now root proc might not need a closure .. since it can be
257: executed all at once
258: *)
259: IntSet.iter (set_closure bbdfns `Heap_closure) !all_closures
260:
261:
262: