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