5.59. C++ Code generator
Start ocaml section to src/flx_pgen.mli[1
/1
]
1: # 4 "./lpsrc/flx_pgen.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_mtypes1
5: open Flx_mtypes2
6: open Flx_label
7: open Flx_ctypes
8:
9: val gen_prim_call :
10: sym_state_t ->
11: fully_bound_symbol_table_t ->
12: (btypecode_t -> btypecode_t) ->
13: (range_srcref -> tbexpr_t -> cexpr_t) ->
14: string ->
15: btypecode_t list ->
16: tbexpr_t ->
17: string ->
18: range_srcref ->
19: range_srcref ->
20: string ->
21: cexpr_t
22:
23: val shape_of:
24: fully_bound_symbol_table_t ->
25: (btypecode_t -> string) ->
26: btypecode_t ->
27: string
28:
Start ocaml section to src/flx_pgen.ml[1
/1
]
1: # 33 "./lpsrc/flx_pgen.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_name
10: open Flx_tgen
11: open Flx_unify
12: open Flx_csubst
13: open Flx_exceptions
14: open Flx_display
15: open List
16: open Flx_generic
17: open Flx_label
18: open Flx_ctypes
19: open Flx_cexpr
20: open Flx_maps
21:
22: let shape_of bbdfns tn t =
23: match t with
24: | `BTYP_inst (i,ts) ->
25: let id,parent,sr,entry = Hashtbl.find bbdfns i in
26: begin match entry with
27: | `BBDCL_union (vs,idts) ->
28: let varmap = mk_varmap vs ts in
29: let cpts = map (fun (_,_,t) -> varmap_subst varmap t) idts in
30: if all_voids cpts then "_int_ptr_map"
31: else "_uctor_ptr_map"
32: | _ -> tn t ^ "_ptr_map"
33: end
34: | `BTYP_pointer _ -> "_ref_ptr_map"
35: | _ -> tn t ^ "_ptr_map"
36:
37: let gen_prim_call
38: syms
39: (bbdfns:fully_bound_symbol_table_t)
40: (tsub:btypecode_t -> btypecode_t)
41: (ge: range_srcref -> tbexpr_t -> cexpr_t)
42: (ct:string)
43: (ts:btypecode_t list)
44: ((arg,argt as a) : tbexpr_t)
45: ret sr sr2 prec
46: =
47: (*
48: print_endline ("ts= "^catmap "," (sbt syms.dfns) ts);
49: print_endline ("argt = " ^ sbt syms.dfns argt);
50: *)
51: let tn t = cpp_typename syms t in
52: let rt t = reduce_type (lstrip syms.dfns (tsub t)) in
53: let rtn t = tn (rt t) in
54:
55: let argt = rt argt in
56: let tt = tn argt in
57: let sh t = shape_of bbdfns tn t in
58: let gshapes = map sh ts in
59: let ts = map rtn ts in
60: let carg =
61: match argt with
62: | `BTYP_tuple [] -> ce_atom "UNIT_VALUE_ERROR"
63: | x -> ge sr a
64: in
65: let ashape = sh argt in
66: match arg,argt with
67:
68: (* the argument is explicitly a tuple *)
69: | (`BEXPR_tuple es,_) ->
70: let ess =
71: map
72: (fun e->
73: match e with
74: (* individual arguments which are unit values are never passed:
75: they CAN be passed as subcomponents though .. but they can't
76: be generated .. we need to fix this!
77: *)
78: | `BEXPR_tuple [],_ ->
79: (*
80: print_endline "Stripping unit";
81: *)
82: `Ce_atom "/*()*/"
83:
84: | _ -> ge sr e
85: )
86: es
87: in
88: let ets,ashapes =
89: match argt with
90: | `BTYP_tuple typs -> map rtn typs, map sh typs
91: | `BTYP_array (t,`BTYP_unitsum n) ->
92: let t = tn t
93: and s = sh t
94: in rev_map (fun _ -> t) (nlist n), rev_map (fun _ -> s) (nlist n)
95: | _ -> assert false
96: in
97: csubst sr sr2 ct carg ess ets tt ret ts prec ashape ashapes ["Error"] gshapes
98:
99: (* the argument isnt a tuple, but the type is *)
100: | (_,`BTYP_tuple typs) as x ->
101: let n = length typs in
102: let typs = map rt typs in
103: let es =
104: map2
105: (fun i t -> `BEXPR_get_n (i,x),t)
106: (nlist n) typs
107: in
108: let ess = map (ge sr) es in
109: let ets = map tn typs in
110: csubst sr sr2 ct carg ess ets tt ret ts prec ashape (map sh typs) ["Error"] gshapes
111:
112: (* the argument isnt a tuple, but the type is an array *)
113: | (_,(`BTYP_array(t,`BTYP_unitsum n) as ta)) as x ->
114: let t = rt t in
115: let typs = map (fun _ -> rt t) (nlist n) in
116: let es =
117: map
118: (fun i -> `BEXPR_get_n (i,x),t)
119: (nlist n)
120: in
121: let ess = map (ge sr) es in
122: let ets = map tn typs in
123: csubst sr sr2 ct carg ess ets tt ret ts prec ashape (map sh typs) ["error"] gshapes
124:
125: (* the argument isn't an explicit tuple, and the type
126: is neither an array nor tuple
127: *)
128: | (_,typ) ->
129: csubst sr sr2 ct carg [carg] [tt] tt ret ts prec ashape [ashape] ["Error"] gshapes
130:
131:
132:
Start ocaml section to src/flx_egen.mli[1
/1
]
1: # 3 "./lpsrc/flx_egen.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_mtypes1
5: open Flx_mtypes2
6: open Flx_label
7: open Flx_ctypes
8:
9: val gen_expr:
10: sym_state_t ->
11: fully_bound_symbol_table_t ->
12: int ->
13: tbexpr_t ->
14: bvs_t ->
15: btypecode_t list ->
16: range_srcref -> string
17:
18: val gen_expr':
19: sym_state_t ->
20: fully_bound_symbol_table_t ->
21: int ->
22: tbexpr_t ->
23: bvs_t ->
24: btypecode_t list ->
25: range_srcref -> cexpr_t
26:
27: val get_var_ref:
28: sym_state_t ->
29: fully_bound_symbol_table_t ->
30: int ->
31: int ->
32: btypecode_t list ->
33: string
34:
Start ocaml section to src/flx_egen.ml[1
/1
]
1: # 38 "./lpsrc/flx_egen.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_name
10: open Flx_tgen
11: open Flx_unify
12: open Flx_csubst
13: open Flx_exceptions
14: open Flx_display
15: open List
16: open Flx_generic
17: open Flx_label
18: open Flx_unravel
19: open Flx_ogen
20: open Flx_ctypes
21: open Flx_cexpr
22: open Flx_maps
23: open Flx_pgen
24: open Flx_beta
25:
26: let string_of_string = Flx_string.c_quote_of_string
27:
28: (* HACKERY: this assumes library dependent things:
29: but we can't add literals in the library code :-(
30: *)
31: let csuffix_of_type s = match s with
32: | "tiny" -> ""
33: | "short" -> ""
34: | "int" -> ""
35: | "long" -> "l"
36: | "vlong" -> "ll"
37: | "utiny" -> "u"
38: | "ushort" -> "u"
39: | "uint" -> "u"
40: | "ulong" -> "ul"
41: | "uvlong" -> "ull"
42: | "int8" -> ""
43: | "int16" -> ""
44: | "int32" -> "l"
45: | "int64" -> "ll"
46: | "uint8" -> "u"
47: | "uint16" -> "u"
48: | "uint32" -> "ul"
49: | "uint64" -> "ull"
50: | "double" -> ""
51: | "float" -> "f"
52: | "ldouble" -> "l"
53: | _ -> failwith ("[csuffix_of_type]: Unexpected Type " ^ s)
54:
55: let cstring_of_literal e = match e with
56: | `AST_int (s,i) -> (Big_int.string_of_big_int i)^csuffix_of_type s
57: | `AST_float (s,x) -> x ^ csuffix_of_type s
58: | `AST_string s -> string_of_string s
59: | `AST_cstring s -> string_of_string s
60: | `AST_wstring s -> "L" ^ string_of_string s
61: | `AST_ustring s -> "L" ^ string_of_string s
62:
63: (* a native literal is one not needing a cast to get the type right *)
64: let is_native_literal e = match e with
65: | `AST_int ("int",_)
66: | `AST_int ("long",_)
67: | `AST_int ("uint",_)
68: | `AST_int ("ulong",_)
69: | `AST_int ("vlong",_)
70: | `AST_int ("uvlong",_)
71: | `AST_float ("double",_) -> true
72: | _ -> false
73:
74: let get_var_frame syms bbdfns this index ts : string =
75: match
76: try Hashtbl.find bbdfns index
77: with Not_found -> failwith ("[get_var_frame(1)] Can't find index " ^ si index)
78: with (id,parent,sr,entry) ->
79: match entry with
80: | `BBDCL_val (vs,t)
81: | `BBDCL_var (vs,t) ->
82: begin match parent with
83: | None -> "0"
84: | Some i ->
85: if i <> this
86: then "ptr" ^ cpp_instance_name syms bbdfns i ts
87: else "this"
88: end
89: | `BBDCL_tmp (vs,t) ->
90: failwith ("[get_var_frame] temporaries aren't framed: " ^ id)
91:
92: | _ -> failwith ("[get_var_frame] Expected name "^id^" to be variable or value")
93:
94: let get_var_ref syms bbdfns this index ts : string =
95: match
96: try Hashtbl.find bbdfns index
97: with Not_found -> failwith ("[get_var_ref] Can't find index " ^ si index)
98: with (id,parent,sr,entry) ->
99: (*
100: print_endline ("get var ref for " ^ id ^ "<" ^ si index ^ ">["^catmap "," (string_of_btypecode syms.dfns) ts^"]");
101: *)
102: match entry with
103: | `BBDCL_val (vs,t)
104: | `BBDCL_var (vs,t) ->
105: begin match parent with
106: | None -> (* print_endline "No parent ...?"; *)
107: "PTF " ^ cpp_instance_name syms bbdfns index ts
108: | Some i ->
109: (*
110: print_endline ("Parent " ^ si i);
111: *)
112: (
113: if i <> this
114: then "ptr" ^ cpp_instance_name syms bbdfns i ts ^ "->"
115: else ""
116: ) ^
117: cpp_instance_name syms bbdfns index ts
118: end
119:
120: | `BBDCL_tmp (vs,t) ->
121: cpp_instance_name syms bbdfns index ts
122:
123: | _ -> failwith ("[get_var_ref(3)] Expected name "^id^" to be variable, value or temporary")
124:
125: let nth_type ts i =
126: try match ts with
127: | `BTYP_tuple ts -> nth ts i
128: | `BTYP_array (t,`BTYP_unitsum n) -> assert (i<n); t
129: | _ -> assert false
130: with Not_found ->
131: failwith ("Can't find component " ^ si i ^ " of type!")
132:
133: let rec gen_expr' syms bbdfns this (e,t) vs ts sr : cexpr_t =
134: (*
135: print_endline ("Generating expression " ^ string_of_bound_expression_with_type syms.dfns (e,t));
136: *)
137: let ge' e = gen_expr' syms bbdfns this e vs ts sr in
138: let ge e = gen_expr syms bbdfns this e vs ts sr in
139: let ge'' sr e = gen_expr' syms bbdfns this e vs ts sr in
140: if length ts <> length vs then
141: failwith
142: (
143: "[gen_expr} wrong number of args, expected vs = " ^
144: si (length vs) ^
145: ", got ts=" ^
146: si (length ts)
147: );
148: let tsub t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
149: let tn t = cpp_typename syms (tsub (lower t)) in
150:
151: (* NOTE this function does not do a reduce_type *)
152: let raw_typename t = cpp_typename syms (beta_reduce syms [] (tsubst vs ts t)) in
153: let gen_case_index e =
154: let _,t = e in
155: let t = lstrip syms.dfns t in
156: begin match t with
157: | `BTYP_sum _
158: | `BTYP_unitsum _
159: | `BTYP_variant _ ->
160: if is_unitsum t then ge' e
161: else ce_dot (ge' e) "variant"
162: | `BTYP_inst (i,ts) ->
163: let ts = map tsub ts in
164: let id,_,_,entry =
165: try Hashtbl.find bbdfns i
166: with Not_found -> failwith ("[gen_expr: case_index] Can't find index " ^ si i)
167: in
168: begin match entry with
169: | `BBDCL_union (bvs,cts) ->
170: let tsub' t = reduce_type (beta_reduce syms [] (tsubst bvs ts t)) in
171: let cts = map (fun (_,_,t) -> tsub' t) cts in
172: if all_voids cts then ge' e
173: else ce_dot (ge' e) "variant"
174: | _ -> failwith ("Woops expected union, got " ^ id)
175: end
176: | _ -> failwith ("Woops expected union or sum, got " ^ sbt syms.dfns t)
177: end
178:
179: in
180: let ge_arg ((x,t) as a) =
181: let t = tsub t in
182: match t with
183: | `BTYP_tuple [] -> ""
184: | _ -> ge a
185: in
186: let id,parent,sr,entry =
187: try Hashtbl.find bbdfns this
188: with Not_found -> failwith ("[gen_expr] Can't find this = " ^ si this)
189: in
190: let our_display = get_display_list bbdfns this in
191: let our_level = length our_display in
192: let rt t = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts t))) in
193: let t = rt t in
194: match t with
195: | `BTYP_tuple [] ->
196: clierr sr
197: ("[egen] In "^sbe syms.dfns (e,t)^":\nunit value required, should have been eliminated")
198:
199: (* ce_atom ("UNIT_ERROR") *)
200: | _ ->
201: match e with
202: | `BEXPR_parse ((_,t')as e,ii) ->
203: let pn =
204: try Hashtbl.find syms.parsers (this,t',ii)
205: with Not_found -> failwith ("[gen_expr] parse can't find parser")
206: in
207: let ln =
208: try Hashtbl.find syms.lexers (this,e)
209: with Not_found -> failwith ("[gen_expr] parse can't find lexer")
210: in
211: let the_display =
212: "this"::
213: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
214: our_display
215: in
216:
217: (* HACK PROPERTIES *)
218: let pdisplay = strd the_display [`Requires_ptf] in
219: let ldisplay = strd (the_display @[ge e]) [`Requires_ptf] in
220: let callstr =
221: "(Elk_" ^ si pn ^ pdisplay ^
222: ".apply((new ElkLex_" ^ si ln^ldisplay^")->init()))"
223: in
224: (*
225: print_endline ("Parse call : " ^ callstr);
226: *)
227: ce_atom callstr
228:
229: | `BEXPR_expr (s,_) -> ce_top s
230:
231: | `BEXPR_case_index e -> gen_case_index e
232:
233: | `BEXPR_range_check (e1,e2,e3) ->
234: let f,sl,sc,el,ec = sr in
235: let f = ce_atom ("\""^ f ^"\"") in
236: let sl = ce_atom (si sl) in
237: let sc = ce_atom (si sc) in
238: let el = ce_atom (si el) in
239: let ec = ce_atom (si ec) in
240: let sref = ce_call (ce_atom "flx::rtl::flx_range_srcref_t") [f;sl;sc;el;ec] in
241: let cf = ce_atom "__FILE__" in
242: let cl = ce_atom "__LINE__" in
243: let args : cexpr_t list =
244: [ ge' e1 ; ge' e2; ge' e3; sref; cf; cl]
245: in
246: ce_call (ce_atom "flx::rtl::range_check") args
247:
248: | `BEXPR_get_n (n,(e',t as e)) ->
249: begin match rt t with
250: | `BTYP_array (_,`BTYP_unitsum _) ->
251: ce_dot (ge' e) ("data["^si n^"]")
252: | `BTYP_record es ->
253: let field_name,_ =
254: try nth es n
255: with Not_found ->
256: failwith "Woops, index of non-existent struct field"
257: in
258: ce_dot (ge' e) field_name
259:
260: | `BTYP_inst (i,_) ->
261: begin match Hashtbl.find bbdfns i with
262: | _,_,_,`BBDCL_struct (_,ls)
263: | _,_,_,`BBDCL_cstruct (_,ls) ->
264: let name,_ =
265: try nth ls n
266: with _ ->
267: failwith "Woops, index of non-existent struct field"
268: in
269: ce_dot (ge' e) name
270:
271: | _ -> failwith "Instance expected to be (c)struct"
272: end
273:
274: | _ -> ce_dot (ge' e) ("mem_" ^ si n)
275: end
276:
277: | `BEXPR_get_named (n,(e',t as e)) ->
278: (*
279: print_endline "Handling get_named expression";
280: *)
281: begin match rt t with
282: | `BTYP_inst (i,ts) ->
283: begin match
284: try Hashtbl.find syms.dfns i
285: with Not_found -> assert false
286: with { id=class_name; symdef=symdef } ->
287: match symdef with
288: | `SYMDEF_class ->
289: begin match
290: try Hashtbl.find syms.dfns n
291: with Not_found -> failwith ("Can't find class "^class_name^"member " ^ si n);
292: with { id = name } ->
293: let cname = cpp_instance_name syms bbdfns n ts in
294: ce_arrow (ge' e) cname
295: end
296: | _ -> clierr sr ("[gen_expr'] Expecting "^si i^" to be class, got " ^ string_of_bbdcl syms.dfns entry i)
297: end
298: | _ -> assert false
299: end
300:
301: | `BEXPR_match_case (n,((e',t') as e)) ->
302: let t' = reduce_type (beta_reduce syms [] (lstrip syms.dfns t')) in
303: let x = gen_case_index e in
304: ce_infix "==" x (ce_atom (si n))
305:
306: (*
307: if is_unitsum t' then
308: ce_infix "==" (ge' e) (ce_atom (si n))
309: else
310: ce_infix "=="
311: (ce_dot (ge' e) "variant")
312: (ce_atom (si n))
313: *)
314:
315: | `BEXPR_case_arg (n,e) ->
316: (*
317: print_endline ("Decoding nonconst ctor type " ^ sbt syms.dfns t);
318: *)
319: begin match t with (* t is the result of the whole expression *)
320: | `BTYP_function _ ->
321: let cast = tn t in
322: ce_cast cast (ce_dot (ge' e) "data")
323: | _ ->
324: let cast = tn t ^ "*" in
325: ce_prefix "*" (ce_cast cast (ce_dot (ge' e) "data"))
326: end
327:
328: | `BEXPR_deref ((`BEXPR_ref index),`BTYP_pointer t) ->
329: ge' (`BEXPR_name index,t)
330:
331: | `BEXPR_deref e ->
332: let cast = tn t ^ "*" in
333: ce_prefix "*" (ce_cast cast (ce_dot (ge' e) "get_data()"))
334:
335: | `BEXPR_literal v ->
336: if is_native_literal v
337: then ce_atom (cstring_of_literal v)
338: else
339: let t = tn t in
340: ce_atom (t ^ "(" ^ cstring_of_literal v ^ ")")
341:
342: | `BEXPR_case (v,t') ->
343: begin match unfold syms.dfns t' with
344: | `BTYP_unitsum n ->
345: if v < 0 or v >= n
346: then
347: failwith
348: (
349: "Invalid case index " ^ si v ^
350: " of " ^ si n ^ " cases in unitsum"
351: )
352: else ce_atom (si v)
353:
354: | `BTYP_sum ls ->
355: let s =
356: let n = length ls in
357: if v < 0 or v >= n
358: then
359: failwith
360: (
361: "Invalid case index " ^ si v ^
362: " of " ^ si n ^ " cases"
363: )
364: else let t' = nth ls v in
365: if t' = `BTYP_tuple []
366: then (* closure of const ctor is just the const value ???? *)
367: if is_unitsum t then
368: si v
369: else
370: "_uctor_(" ^ si v ^ ",0)"
371: else
372: failwith
373: (
374: "Can't handle closure of case " ^
375: si v ^
376: " of " ^
377: string_of_btypecode syms.dfns t
378: )
379: in ce_atom s
380: (* "(" ^ tn (lower t) ^ "*)_uctor_" *)
381:
382: | _ -> failwith "Case tag must have sum type"
383: end
384:
385: | `BEXPR_name (index,ts') ->
386: let id,parent,sr2,entry =
387: try Hashtbl.find bbdfns index
388: with _ ->
389: match
390: try Hashtbl.find syms.dfns index
391: with Not_found -> assert false
392: with
393: {id=id; sr=sr} -> syserr sr
394: ("[gen_expr(name)] Can't find "^ id ^ "<" ^ si index ^ ">")
395: in
396: let ts = map tsub ts' in
397: begin match entry with
398: | `BBDCL_var (_,t)
399: | `BBDCL_val (_,t)
400: | `BBDCL_tmp (_,t)
401: ->
402: ce_atom (get_var_ref syms bbdfns this index ts)
403:
404: | `BBDCL_const (_,_,ct,_) ->
405: begin match ct with
406: | `Str c
407: | `StrTemplate c when c = "#srcloc" ->
408: let filename, startline, startcol, endline, endcol = sr in
409: ce_atom ("flx::rtl::flx_range_srcref_t(" ^
410: string_of_string filename ^ "," ^
411: si startline ^ "," ^
412: si startcol ^ "," ^
413: si endline ^ "," ^
414: si endcol ^ ")"
415: )
416:
417: | `Str c
418: | `StrTemplate c when c = "#memcount" ->
419: let ts = map (lstrip syms.dfns) ts in
420: begin match ts with
421: | [`BTYP_unitsum n]
422: | [`BTYP_array (_,`BTYP_unitsum n)] -> ce_atom (si n)
423: | [`BTYP_sum ls]
424: | [`BTYP_tuple ls] -> let n = length ls in ce_atom (si n)
425: | [`BTYP_inst (i,_)] ->
426: let _,_,_,entry = Hashtbl.find bbdfns i in
427: begin match entry with
428: | `BBDCL_struct (_,ls) -> let n = length ls in ce_atom (si n)
429: | `BBDCL_cstruct (_,ls) -> let n = length ls in ce_atom (si n)
430: | `BBDCL_union (_,ls) -> let n = length ls in ce_atom (si n)
431: | `BBDCL_class (_,ls) -> let n = length ls in ce_atom (si n)
432: | _ ->
433: clierr sr (
434: "#memcount function requires type with members to count, got: " ^
435: sbt syms.dfns (hd ts)
436: )
437: end
438: | _ ->
439: clierr sr (
440: "#memcount function requires type with members to count, got : " ^
441: sbt syms.dfns (hd ts)
442: )
443: end
444: | `Str c -> ce_expr "expr" c
445: | `StrTemplate c ->
446: let ts = map tn ts in
447: csubst sr sr2 c (ce_atom "Error") [] [] "Error" "Error" ts "expr" "Error" ["Error"] ["Error"] ["Error"]
448: end
449:
450: (* | `BBDCL_function (_,_,([s,(_,`BTYP_void)],_),_,[`BEXE_fun_return e]) -> *)
451: | `BBDCL_function (_,_,([],_),_,[`BEXE_fun_return (_,e)]) ->
452: ge' e
453:
454: | `BBDCL_cstruct _
455: | `BBDCL_struct _
456: | `BBDCL_reglex _
457: | `BBDCL_regmatch _
458: | `BBDCL_function _
459: | `BBDCL_procedure _
460: | `BBDCL_fun _
461: | `BBDCL_proc _ ->
462: syserr sr
463: (
464: "[gen_expr: name] Open function '" ^
465: id ^ "'<"^si index^
466: "> in expression (closure required)"
467: )
468: | _ ->
469: syserr sr
470: (
471: "[gen_expr: name] Cannot use this kind of name '"^
472: id^"' in expression"
473: )
474: end
475:
476: | `BEXPR_closure (index,ts') ->
477: (*
478: print_endline ("Generating closure of " ^ si index);
479: *)
480: let id,parent,sr,entry =
481: try Hashtbl.find bbdfns index
482: with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
483: in
484: (*
485: Should not be needed now ..
486: let ts = adjust_ts syms index ts' in
487: *)
488: let ts = map tsub ts' in
489: begin match entry with
490: | `BBDCL_function (props,_,_,_,_)
491: | `BBDCL_procedure (props,_,_,_) ->
492: let the_display =
493: let d' =
494: map (fun (i,vslen) -> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
495: (get_display_list bbdfns index)
496: in
497: if length d' > our_level
498: then "this" :: tl d'
499: else d'
500: in
501: let name = cpp_instance_name syms bbdfns index ts in
502: ce_atom (
503: "(FLX_NEWP("^name^")" ^ strd the_display props ^")"
504: )
505:
506: | `BBDCL_callback _ ->
507: print_endline "Mapping closure of callback to C function pointer";
508: ce_atom id
509:
510: | `BBDCL_cstruct _
511: | `BBDCL_struct _
512: | `BBDCL_fun _
513: | `BBDCL_proc _ ->
514: failwith ("[gen_expr: closure] Can't wrap primitive proc, fun, or struct '"^id^"' yet")
515: | _ -> failwith ("[gen_expr: closure] Cannot use this kind of name '"^id^"' in expression")
516: end
517:
518: | `BEXPR_apply_method_stack (obj,meth,ts',a) ->
519: let id,parent,sr2,entry =
520: try Hashtbl.find bbdfns meth
521: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si meth)
522: in
523: begin
524: (*
525: print_endline ("apply method closure of "^ id );
526: print_endline (" .. argument is " ^ string_of_bound_expression syms.dfns a);
527: *)
528: match entry with
529: | `BBDCL_function (props,_,_,_,_) ->
530: (*
531: print_endline ("Generating closure[apply method stack] of " ^ si meth);
532: *)
533: let ts = map tsub ts' in
534: let the_display =
535: let d' =
536: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
537: (get_display_list bbdfns meth)
538: in
539: let d' = tl d' in (* throw out class pointer *)
540: if length d' > our_level
541: then "this" :: tl d'
542: else d'
543: in
544: let class_frame = ge obj in
545: let the_display = class_frame :: the_display in
546: let name = cpp_instance_name syms bbdfns meth ts in
547: ce_atom (
548: name ^ strd the_display props ^
549: "\n .apply(" ^ ge_arg a ^ ")"
550: )
551: | _ ->
552: failwith
553: (
554: "[gen_expr: apply_method_stack] Expected '"^id^"' to be generic function instance, got:\n" ^
555: string_of_bbdcl syms.dfns entry meth
556: )
557: end
558:
559: | `BEXPR_apply_method_direct (obj,meth,ts',a) ->
560: let id,parent,sr2,entry =
561: try Hashtbl.find bbdfns meth
562: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si meth)
563: in
564: begin
565: (*
566: print_endline ("apply method closure of "^ id );
567: print_endline (" .. argument is " ^ string_of_bound_expression syms.dfns a);
568: *)
569: match entry with
570: | `BBDCL_function (props,_,_,_,_) ->
571: (*
572: print_endline ("Generating closure[apply method direct] of " ^ si meth);
573: *)
574: let ts = map tsub ts' in
575: let the_display =
576: let d' =
577: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
578: (get_display_list bbdfns meth)
579: in
580: let d' = tl d' in (* throw out class pointer *)
581: if length d' > our_level
582: then "this" :: tl d'
583: else d'
584: in
585: let class_frame = ge obj in
586: let the_display = class_frame :: the_display in
587: let name = cpp_instance_name syms bbdfns meth ts in
588: ce_atom (
589: "(FLX_NEWP("^name^")"^ strd the_display props ^")"^
590: "\n ->apply(" ^ ge_arg a ^ ")"
591: )
592:
593: | _ ->
594: failwith
595: (
596: "[gen_expr: apply_method_direct] Expected '"^id^"' to be generic function instance, got:\n" ^
597: string_of_bbdcl syms.dfns entry meth
598: )
599: end
600:
601: | `BEXPR_method_closure (e,index,ts') ->
602: (*
603: print_endline ("Generating method closure of " ^ si index);
604: *)
605: let id,parent,sr,entry =
606: try Hashtbl.find bbdfns index
607: with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
608: in
609: (*
610: Should not be needed now ..
611: let ts = adjust_ts syms index ts' in
612: *)
613: let ts = map tsub ts' in
614: begin match entry with
615: | `BBDCL_function (props,_,_,_,_)
616: | `BBDCL_procedure (props,_,_,_) ->
617: (*
618: print_endline ("Method " ^ id ^ (
619: if mem `Requires_ptf props then
620: " REQUIRES PTF" else " DOES NOT REQUIRE PTF"
621: )
622: );
623: *)
624: let the_display =
625: let d' =
626: map (fun (i,vslen) -> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
627: (get_display_list bbdfns index)
628: in
629: let d' = tl d' in (* throw out class pointer *)
630:
631: (*
632: print_endline ("Generated display is " ^ cat ", " d');
633: print_endline ("Display length = " ^ si (length d') ^ " .. our level = " ^ si our_level);
634: *)
635:
636: assert (length d' >= our_level);
637: if length d' > our_level
638: then "this" :: tl d'
639: else d'
640: in
641: (* A method closure requires the last entry in the display
642: to be the class. If we're cross calling from one
643: method to another, we should automatically get the
644: parent class environment, but I'm not sure ..
645: *)
646: let class_frame = ge e in
647: let the_display = class_frame :: the_display in
648: let name = cpp_instance_name syms bbdfns index ts in
649: ce_atom (
650: "(FLX_NEWP("^name^")" ^ strd the_display props ^")"
651: )
652:
653: | `BBDCL_cstruct _
654: | `BBDCL_struct _
655: | `BBDCL_fun _
656: | `BBDCL_proc _ ->
657: failwith ("[gen_expr: closure] Can't wrap primitive proc, fun, or struct '"^id^"' yet")
658: | _ -> failwith ("[gen_expr: closure] Cannot use this kind of name '"^id^"' in expression")
659: end
660:
661: | `BEXPR_ref (index,ts') ->
662: let ts = map tsub ts' in
663: let t = lower t in
664: let ref_type = tn (lower t) in
665: let frame_ptr, var_ptr =
666: match t with
667: | `BTYP_tuple [] -> "NULL","0"
668: | _ ->
669: let parent = match Hashtbl.find bbdfns index with _,parent,sr,_ -> parent in
670: if Some this = parent &&
671: (
672: let props = match entry with
673: | `BBDCL_procedure (props,_,_,_)
674: | `BBDCL_function (props,_,_,_,_) -> props
675: | _ -> assert false
676: in
677: mem `Pure props && not (mem `Heap_closure props)
678: )
679: then
680: "NULL","&"^get_var_ref syms bbdfns this index ts ^"-NULL"
681: else
682: get_var_frame syms bbdfns this index ts,
683: "&" ^ get_var_ref syms bbdfns this index ts
684: in
685: let reference = ref_type ^
686: "(" ^ frame_ptr ^ ", " ^ var_ptr ^ ")"
687: in
688: ce_atom reference
689:
690: (* Hackery -- we allow a constructor with no
691: arguments to be applied to a unit anyhow
692: *)
693:
694: | `BEXPR_variant (s,((_,t') as e)) ->
695: print_endline ("Variant " ^ s);
696: print_endline ("Type " ^ sbt syms.dfns t);
697: let
698: arg_typename = tn t' and
699: union_typename = tn t
700: in
701: let aval =
702: "new (*PTF gc, "^arg_typename^"_ptr_map) " ^
703: arg_typename ^ "(" ^ ge_arg e ^ ")"
704: in
705: let ls = match t with
706: | `BTYP_variant ls -> ls
707: | _ -> failwith "[egen] Woops variant doesn't have variant type"
708: in
709: let vidx = match list_assoc_index ls s with
710: | Some i -> i
711: | None -> failwith "[egen] Woops, variant field not in type"
712: in
713: print_endline ("Index " ^ si vidx);
714: let uval = "_uctor_("^si vidx^"," ^ aval ^")" in
715: ce_atom uval
716:
717: | `BEXPR_coerce ((srcx,srct) as srce,dstt) ->
718: let srct = lstrip syms.dfns srct in
719: let vts =
720: match dstt with
721: | `BTYP_variant ls -> ls
722: | _ -> syserr sr "Coerce non-variant"
723: in
724: begin match srcx with
725: | `BEXPR_variant (s,argt) ->
726: print_endline "Coerce known variant!";
727: ge' (`BEXPR_variant (s,argt),t)
728: | _ ->
729: let i =
730: begin try
731: Hashtbl.find syms.variant_map (srct,dstt)
732: with Not_found ->
733: let i = !(syms.counter) in incr (syms.counter);
734: Hashtbl.add syms.variant_map (srct,dstt) i;
735: i
736: end
737: in
738: ce_atom ("_uctor_(vmap_"^si i^","^ge srce^")")
739: end
740:
741: | `BEXPR_apply
742: (
743: (`BEXPR_case (v,t),t'),
744: (a,t'')
745: ) ->
746: (* t is the type of the sum,
747: t' is the function type of the constructor,
748: t'' is the type of the argument
749: *)
750: let
751: arg_typename = tn (lower t'')
752: and
753: union_typename = tn (lower t)
754: in
755: let aval =
756: "new (*PTF gc, "^arg_typename^"_ptr_map) " ^
757: arg_typename ^ "(" ^ ge_arg (a,t'') ^ ")"
758: in
759: let uval =
760: if is_unitsum t then
761: si v
762: else
763: "_uctor_(" ^ si v ^ ", " ^ aval ^")"
764: in
765: let s = "(" ^ union_typename ^ ")" ^ uval in
766: ce_atom s
767:
768: (*
769: failwith
770: (
771: "Trapped application, case " ^
772: si v ^
773: " of " ^ string_of_btypecode syms.dfns t ^
774: "\ntype " ^ string_of_btypecode syms.dfns t' ^
775: "\nargument=" ^
776: string_of_bound_expression syms.dfns (a,t'') ^
777: "\ntype " ^ string_of_btypecode syms.dfns t''
778: )
779: *)
780:
781:
782: | `BEXPR_apply_prim (index,ts,(arg,argt as a)) ->
783: (*
784: print_endline ("Prim apply, arg=" ^ sbe syms.dfns a);
785: *)
786: let argt = tsub argt in
787: let id,parent,sr2,entry =
788: try Hashtbl.find bbdfns index
789: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
790: in
791: begin
792: match entry with
793: | `BBDCL_fun (props,vs,ps,retyp,ct,_,prec) ->
794: if length vs <> length ts then
795: failwith
796: (
797: "[get_expr:apply closure of fun] function " ^
798: id ^ "<" ^ si index ^">" ^
799: ", wrong number of args, expected vs = " ^
800: si (length vs) ^
801: ", got ts=" ^
802: si (length ts)
803: );
804: begin match ct with
805: | `Str s -> ce_expr prec s
806: | `StrTemplate s ->
807: let ts = map tsub ts in
808: let retyp = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts retyp))) in
809: let retyp = tn retyp in
810: gen_prim_call syms bbdfns tsub ge'' s ts (arg,argt) retyp sr sr2 prec
811: end
812:
813: | `BBDCL_callback (props,vs,ps_cf,ps_c,_,retyp,_,_) ->
814: assert (retyp <> `BTYP_void);
815: if length vs <> length ts then
816: clierr sr "[gen_prim_call] Wrong number of type arguments"
817: ;
818: let ts = map tsub ts in
819: let s = id ^ "($a)" in
820: let retyp = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts retyp))) in
821: let retyp = tn retyp in
822: gen_prim_call syms bbdfns tsub ge'' s ts (arg,argt) retyp sr sr2 "atom"
823:
824: (* but can't be a Felix function *)
825: | _ ->
826: failwith
827: (
828: "[gen_expr: apply prim] Expected '"^id^"' to be primitive function instance, got:\n" ^
829: string_of_bbdcl syms.dfns entry index
830: )
831: end
832:
833: | `BEXPR_apply_struct (index,ts,a) ->
834: let id,parent,sr2,entry =
835: try Hashtbl.find bbdfns index
836: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
837: in
838: let ts = map tsub ts in
839: begin match entry with
840: | `BBDCL_cstruct (vs,_) ->
841: let name = tn (`BTYP_inst (index,ts)) in
842: ce_atom ("reinterpret<"^ name ^">(" ^ ge a ^ ")")
843:
844: | `BBDCL_struct (vs,cts) ->
845: let name = tn (`BTYP_inst (index,ts)) in
846: if length cts > 1 then
847: (* argument must be an lvalue *)
848: ce_atom ("reinterpret<"^ name ^">(" ^ ge a ^ ")")
849: else if length cts = 0 then
850: ce_atom (name ^ "()")
851: else
852: ce_atom (name ^ "(" ^ ge a ^ ")")
853:
854: | `BBDCL_nonconst_ctor (vs,uidx,udt,cidx,ct) ->
855: (* due to some hackery .. the argument of a non-const
856: ctor can STILL be a unit .. prolly cause the stupid
857: compiler is checking for voids for these pests,
858: but units for sums .. hmm .. inconsistent!
859: *)
860: let ts = map tsub ts in
861: let ct = reduce_type (beta_reduce syms [] (tsubst vs ts ct)) in
862: let _,t = a in
863: let t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
864: begin match t with
865: | `BTYP_tuple [] ->
866: ce_atom ( "_uctor_(" ^ si cidx ^ ", NULL)")
867:
868: (* function types are already pointers .. any use of this
869: should do a clone ..
870: *)
871: | `BTYP_function _ ->
872: ce_atom (
873: "_uctor_(" ^ si cidx ^ ", " ^ ge a ^")"
874: )
875:
876: | _ ->
877: let ctt = tn ct in
878: let ptrmap = shape_of bbdfns tn ct in
879: ce_atom (
880: "_uctor_(" ^ si cidx ^ ", new(*PTF gc,"^ ptrmap^")"^
881: ctt ^"("^ ge a ^"))"
882: )
883: end
884: | _ -> assert false
885: end
886:
887: | `BEXPR_apply_direct (index,ts,a) ->
888: let id,parent,sr2,entry =
889: try Hashtbl.find bbdfns index
890: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
891: in
892: begin
893: (*
894: print_endline ("apply closure of "^ id );
895: print_endline (" .. argument is " ^ string_of_bound_expression syms.dfns a);
896: *)
897: match entry with
898: | `BBDCL_regmatch (props,_,_,_,_)
899: | `BBDCL_reglex (props,_,_,_,_,_)
900: | `BBDCL_function (props,_,_,_,_) ->
901: (*
902: print_endline ("Generating closure[apply direct] of " ^ si index);
903: *)
904: let ts = map tsub ts in
905: let the_display =
906: let d' =
907: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
908: (get_display_list bbdfns index)
909: in
910: if length d' > our_level
911: then "this" :: tl d'
912: else d'
913: in
914: let name = cpp_instance_name syms bbdfns index ts in
915: ce_atom (
916: "(FLX_NEWP("^name^")"^ strd the_display props ^")"^
917: "\n ->apply(" ^ ge_arg a ^ ")"
918: )
919:
920: | `BBDCL_fun _ -> assert false
921: (*
922: ge' (`BEXPR_apply_prim (index,ts,a),t)
923: *)
924:
925: | _ ->
926: failwith
927: (
928: "[gen_expr: apply_direct] Expected '"^id^"' to be generic function instance, got:\n" ^
929: string_of_bbdcl syms.dfns entry index
930: )
931: end
932:
933: | `BEXPR_apply_stack (index,ts,a) ->
934: let id,parent,sr2,entry =
935: try Hashtbl.find bbdfns index
936: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
937: in
938: begin
939: (*
940: print_endline ("apply closure of "^ id );
941: print_endline (" .. argument is " ^ string_of_bound_expression syms.dfns a);
942: *)
943: match entry with
944: | `BBDCL_function (props,vs,(ps,traint),retyp,_) ->
945: let ts = map tsub ts in
946: let display = get_display_list bbdfns index in
947: let name = cpp_instance_name syms bbdfns index ts in
948:
949: (* C FUNCTION CALL *)
950: if mem `Pure props && not (mem `Heap_closure props) then
951: let s =
952: assert (length display = 0);
953: match ps with
954: | [] -> ""
955: | [_,(ix,t)] ->
956: if Hashtbl.mem syms.instances (ix,ts)
957: then ge_arg a
958: else ""
959:
960: | _ ->
961: begin match a with
962: | `BEXPR_tuple xs,_ ->
963: (*
964: print_endline ("Arg to C function is tuple " ^ sbe syms.dfns a);
965: *)
966: fold_left2
967: (fun s ((x,t) as xt) (_,(ix,_)) ->
968: let x =
969: if Hashtbl.mem syms.instances (ix,ts)
970: then ge_arg xt
971: else ""
972: in
973: if String.length x = 0 then s else
974: s ^
975: (if String.length s > 0 then ", " else "") ^ (* append a comma if needed *)
976: x
977: )
978: ""
979: xs ps
980:
981: | _,tt ->
982: let tt = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts tt))) in
983: (* NASTY, EVALUATES EXPR MANY TIMES .. *)
984: let n = ref 0 in
985: fold_left
986: (fun s i ->
987: (*
988: print_endline ( "ps = " ^ catmap "," (fun (id,(p,t)) -> id) ps);
989: print_endline ("tt=" ^ sbt syms.dfns tt);
990: *)
991: let t = nth_type tt i in
992: let a' = `BEXPR_get_n (i,a),t in
993: let x = ge_arg a' in
994: incr n;
995: if String.length x = 0 then s else
996: s ^ (if String.length s > 0 then ", " else "") ^ x
997: )
998: ""
999: (nlist (length ps))
1000: end
1001: in
1002: let s =
1003: if mem `Requires_ptf props then
1004: if String.length s > 0 then "FLX_FPAR_PASS " ^ s
1005: else "FLX_FPAR_PASS_ONLY"
1006: else s
1007: in
1008: ce_atom (name ^ "(" ^ s ^ ")")
1009: else
1010: let the_display =
1011: let d' =
1012: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
1013: display
1014: in
1015: if length d' > our_level
1016: then "this" :: tl d'
1017: else d'
1018: in
1019: let s =
1020: name^ strd the_display props
1021: ^
1022: "\n .apply(" ^ ge_arg a ^ ")"
1023: in ce_atom s
1024:
1025: | _ ->
1026: failwith
1027: (
1028: "[gen_expr: apply_stack] Expected '"^id^"' to be generic function instance, got:\n" ^
1029: string_of_bbdcl syms.dfns entry index
1030: )
1031: end
1032:
1033: | `BEXPR_apply ((`BEXPR_closure (index,ts),_),a) ->
1034: assert false (* should have been factored out *)
1035:
1036: (* application of C function pointer, type
1037: f: a --> b
1038: *)
1039: | `BEXPR_apply ( (_,`BTYP_cfunction _) as f,a) ->
1040: ce_atom (
1041: (ge f) ^"(" ^ ge_arg a ^ ")"
1042: )
1043:
1044: (* General application*)
1045: | `BEXPR_apply (f,a) ->
1046: ce_atom (
1047: (ge f) ^ "->clone()\n ->apply(" ^ ge_arg a ^ ")"
1048: )
1049:
1050: | `BEXPR_record es ->
1051: let rcmp (s1,_) (s2,_) = compare s1 s2 in
1052: let es = sort rcmp es in
1053: let es = map snd es in
1054: let ctyp = tn (lower t) in
1055: ce_atom (
1056: ctyp ^ "(" ^
1057: fold_left
1058: (fun s e ->
1059: let x = ge_arg e in
1060: if String.length x = 0 then s else
1061: s ^
1062: (if String.length s > 0 then ", " else "") ^
1063: x
1064: )
1065: ""
1066: es
1067: ^
1068: ")"
1069: )
1070:
1071: | `BEXPR_tuple es ->
1072: (*
1073: print_endline ("Eval tuple " ^ sbe syms.dfns (e,t));
1074: *)
1075: (* just apply the tuple type ctor to the arguments *)
1076: begin match t with
1077: | `BTYP_array (t',`BTYP_unitsum n) ->
1078: let tuple =
1079: let t'' = `BTYP_tuple (map (fun _ -> t') (nlist n)) in
1080: let ctyp = raw_typename t'' in
1081: ce_atom (
1082: ctyp ^ "(" ^
1083: fold_left
1084: (fun s e ->
1085: let x = ge_arg e in
1086: if String.length x = 0 then s else
1087: s ^
1088: (if String.length s > 0 then ", " else "") ^
1089: x
1090: )
1091: ""
1092: es
1093: ^
1094: ")"
1095: )
1096: in
1097: (* cast a tuple which is an array type to an array *)
1098: let atyp = tn (lower t) in
1099: ce_call
1100: (ce_atom ("reinterpret<" ^ atyp ^">"))
1101: [tuple]
1102:
1103: | `BTYP_tuple _ ->
1104: let ctyp = tn (lower t) in
1105: ce_atom (
1106: ctyp ^ "(" ^
1107: fold_left
1108: (fun s e ->
1109: let x = ge_arg e in
1110: if String.length x = 0 then s else
1111: s ^
1112: (if String.length s > 0 then ", " else "") ^
1113: x
1114: )
1115: ""
1116: es
1117: ^
1118: ")"
1119: )
1120: | _ -> assert false
1121: end
1122:
1123: and gen_expr syms bbdfns this e vs ts sr =
1124: let e = Flx_maps.reduce_tbexpr bbdfns e in
1125: let s =
1126: try gen_expr' syms bbdfns this e vs ts sr
1127: with Unknown_prec p -> clierr sr
1128: ("[gen_expr] Unknown precedence name '"^p^"' in " ^ sbe syms.dfns e)
1129: in
1130: string_of_cexpr s
1131:
1132:
Start ocaml section to src/flx_ctorgen.mli[1
/1
]
1: # 3 "./lpsrc/flx_ctorgen.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_mtypes1
5: open Flx_mtypes2
6: open Flx_label
7:
8: val gen_ctor:
9: sym_state_t ->
10: fully_bound_symbol_table_t ->
11: string -> (* name *)
12: (int * int) list -> (* display *)
13: (int * btypecode_t) list -> (* funs *)
14: (string * string) list -> (* extra args *)
15: string list -> (* extra inits *)
16: btypecode_t list -> (* ts *)
17: property_t list -> (* properties *)
18: string
19:
Start ocaml section to src/flx_ctorgen.ml[1
/1
]
1: # 23 "./lpsrc/flx_ctorgen.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_name
10: open Flx_tgen
11: open Flx_unify
12: open Flx_csubst
13: open Flx_exceptions
14: open Flx_display
15: open List
16: open Flx_generic
17: open Flx_label
18: open Flx_unravel
19: open Flx_ogen
20: open Flx_ctypes
21: open Flx_cexpr
22: open Flx_maps
23:
24: let gen_ctor syms bbdfns name display funs extra_args extra_inits ts props =
25: let requires_ptf = mem `Requires_ptf props in
26: name^"::"^name^
27: (if length display + length extra_args = 0 then
28: (if requires_ptf then "(FLX_FPAR_DECL_ONLY)" else "()")
29: else
30: "\n (\n" ^
31: (if requires_ptf then
32: " FLX_FPAR_DECL\n"
33: else ""
34: )
35: ^
36: cat ",\n"
37: (
38: map
39: (
40: fun (i,vslen) ->
41: let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
42: " " ^ instname ^ " *pptr" ^ instname
43: )
44: display
45: @
46: map
47: (
48: fun (t,a) -> " " ^ t ^ " _"^a
49: )
50: extra_args
51: )^
52: "\n )\n"
53: )
54: ^
55: (if length display + length funs + length extra_args + length extra_inits = 0
56: then (if requires_ptf then "FLX_FMEM_INIT_ONLY" else "")
57: else
58: (if requires_ptf then
59: " FLX_FMEM_INIT "
60: else " : "
61: )
62: ^
63: cat ",\n"
64: (
65: map
66: (
67: fun (i,vslen) -> let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
68: " ptr" ^ instname ^ "(pptr"^instname^")"
69: )
70: display
71: @
72: map
73: (fun (index,t)->
74: cpp_instance_name syms bbdfns index ts
75: ^ "(0)"
76: )
77: funs
78: @
79: map
80: (fun (t,a) -> " " ^a ^ "(_"^a^")")
81: extra_args
82: @
83: map
84: (fun x -> " " ^x)
85: extra_inits
86: )) ^
87: " {}\n"
88:
89:
Start ocaml section to src/flx_elkgen.mli[1
/1
]
1: # 3 "./lpsrc/flx_elkgen.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_mtypes1
5: open Flx_mtypes2
6: open Flx_label
7: open Flx_ctorgen
8:
9: val gen_elk_parser:
10: string ->
11: string ->
12: sym_state_t ->
13: fully_bound_symbol_table_t ->
14: int ->
15: range_srcref ->
16: btypecode_t ->
17: int ->
18: int list ->
19: unit
20:
21: val gen_elk_lexer:
22: string ->
23: string ->
24: sym_state_t ->
25: fully_bound_symbol_table_t ->
26: int ->
27: range_srcref ->
28: tbexpr_t ->
29: int ->
30: unit
31:
32:
Start ocaml section to src/flx_elkgen.ml[1
/1
]
1: # 36 "./lpsrc/flx_elkgen.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_name
10: open Flx_tgen
11: open Flx_unify
12: open Flx_csubst
13: open Flx_exceptions
14: open Flx_display
15: open List
16: open Flx_generic
17: open Flx_label
18: open Flx_unravel
19: open Flx_ogen
20: open Flx_ctypes
21: open Flx_cexpr
22: open Flx_maps
23: open Flx_egen
24: open Flx_pgen
25: open Flx_ctorgen
26:
27: let gen_elk_lexer filebase module_name syms bbdfns this sr ((_,t') as e) n =
28: let lexer_name = "ElkLex_"^si n in
29: let ge e = gen_expr syms bbdfns this e [] [] sr in
30: let tn t = cpp_typename syms t in
31: let get_token_fun_type = tn t' in
32:
33: let display = cal_display bbdfns (Some this) in
34: let frame_dcls =
35: " FLX_FMEM_DECL\n"
36: in
37: let display_string =
38: cat ""
39: (
40: map
41: (fun (i, vslen) ->
42: try
43: let instname = cpp_instance_name syms bbdfns i [] in
44: " " ^ instname ^ " *ptr" ^ instname ^ ";\n"
45: with _ -> failwith "Can't cal display name"
46: )
47: display
48: )
49: and ctor_dcl =
50: " "^lexer_name ^ "(\n" ^
51: " FLX_FPAR_DECL\n" ^
52: cat ""
53: (
54: map
55: (
56: fun (i,vslen) ->
57: let instname = cpp_instance_name syms bbdfns i [] in
58: " " ^ instname ^ "*,\n"
59: )
60: display
61: )^
62: " "^get_token_fun_type ^"\n );\n"
63: in
64: let filename = filebase ^ "_lexer_" ^ si n ^ ".hpp" in
65: if syms.compiler_options.print_flag then
66: print_endline ("Generating Elkhound lexer " ^ lexer_name ^ " in " ^ filename);
67:
68: let f = open_out filename in
69: let pe s = output_string f (s ^ "\n") in
70:
71: let token_type, token_type_name, token_id, cts =
72: match t' with
73: | `BTYP_function (`BTYP_tuple [],`BTYP_inst(i,[])) ->
74: let id,parent,sr',entry = Hashtbl.find bbdfns i in
75: let token_type = `BTYP_inst(i,[]) in
76: let token_type_name = tn token_type in
77: begin match entry with
78: | `BBDCL_union ([],cts) -> token_type, token_type_name, id, cts
79: | _ -> assert false
80: end
81: | _ -> assert false
82: in
83: pe ("#ifndef ELKLEX_"^si n);
84: pe ("#define ELKLEX_"^si n);
85: pe "#include \"elk_lexerint.h\"";
86: pe "";
87: pe ("struct "^lexer_name^": public LexerInterface {");
88: pe (" //frame");
89: pe frame_dcls;
90: pe (" //display");
91: pe display_string;
92: pe (" // constructor");
93: pe ctor_dcl;
94: pe (" " ^ get_token_fun_type ^ " get_token; // client token generator");
95: pe (" collector_t &gc; // Felix garbage collector");
96: pe " void setToken(); //fetch next token ";
97: pe (" "^lexer_name^" *init(); //prime the lexer");
98: pe "";
99: pe " //Elkhound API";
100: pe " static void nextToken(LexerInterface *lex);";
101: pe " NextTokenFunc getTokenFunc() const { return &nextToken; }";
102: pe " sm_string tokenDesc() const;";
103: pe " sm_string tokenKindDesc(int kind) const;";
104: pe "};";
105: pe "#endif";
106: close_out f;
107:
108: let filename = filebase ^ "_lexer_" ^ si n ^ ".cpp" in
109: let f = open_out filename in
110: let pe s = output_string f (s ^ "\n") in
111: pe ("#include \""^module_name^"_lexer_"^si n^".hpp\"");
112: pe ("//token type = " ^ token_type_name);
113: pe ("static char *"^token_id^"_desc["^si (length cts)^"]={");
114: iter (fun (nm,_,_) -> pe (" \""^nm^"\",")) cts;
115: pe ("};");
116: pe "";
117: (* FUDGE PROPERTY LIST *)
118: let props : property_t list = [`Uses_gc; `Requires_ptf] in
119: pe (gen_ctor syms bbdfns lexer_name display [] [get_token_fun_type,"get_token"] ["gc(*PTF gc)"] [] props);
120: pe ("sm_string " ^ lexer_name ^ "::tokenDesc() const { return tokenKindDesc(type); }");
121: pe "";
122: pe ("sm_string " ^ lexer_name ^ "::tokenKindDesc(int kind) const {");
123: pe (" return "^token_id^"_desc[kind];");
124: pe ("}");
125: pe "";
126: pe ("void " ^ lexer_name ^ "::setToken() {");
127: pe (" _uctor_ token = get_token->apply();");
128: pe (" type = token.variant;");
129: pe (" sval = (SemanticValue)token.data;");
130: pe ("}");
131: pe "";
132: pe ("void " ^ lexer_name ^ "::nextToken(LexerInterface *lex) {");
133: pe (" (("^lexer_name^"*)lex)->setToken();");
134: pe ("}");
135: pe "";
136: pe (lexer_name^" *"^lexer_name^"::init(){");
137: pe (" nextToken(this);");
138: pe (" return this;");
139: pe ("}");
140:
141: close_out f
142:
143: let gen_elk_parser filebase module_name syms bbdfns this sr t' n ii =
144: let filename = filebase ^ "_parser_" ^ si n ^ ".gr" in
145: let parser_name = "_" ^ si n in
146: if syms.compiler_options.print_flag then
147: print_endline ("Generating Elkhound parser " ^ filename)
148: ;
149: let f = open_out filename in
150: let pe s = output_string f (s ^ "\n") in
151: let ps s = output_string f s in
152: let ge_arg this ((x,t) as e) =
153: match t with
154: | `BTYP_tuple [] -> ""
155: | _ -> gen_expr syms bbdfns this e [] [] sr
156: in
157: let tn t = cpp_typename syms (reduce_type t) in
158: let string_of_bprod (n,g) =
159: (match n with | None -> "" | Some n -> cid_of_flxid n ^ ":") ^
160: (match g with
161: | `Term k ->
162: (match Hashtbl.find syms.dfns k with {id=id}->cid_of_flxid id)
163: | `Nonterm (k::_) ->
164: (match Hashtbl.find syms.dfns k with {id=id}->cid_of_flxid id)
165: | _ -> assert false
166: )
167: in
168: let print_production (this,p,xs) =
169: match xs with
170: | [`BEXE_fun_return (_,((_,t) as e))] ->
171: let t = tn t in
172: ps (" -> ");
173: ps (catmap " " string_of_bprod p);
174: pe "";
175: pe " {";
176: pe (" "^t^" *_x = new "^t^"(" ^ ge_arg this e ^ ");");
177: iter
178: (function
179: | Some n, `Nonterm _ -> pe (" delete " ^ n^";")
180: | _ -> ()
181: )
182: p;
183: pe (" return _x;");
184: pe " }";
185: | _ -> assert false
186: in
187: let set_of_list ii : IntSet.t = fold_left (fun s elt ->IntSet.add elt s) IntSet.empty ii in
188: let nts_of_prod p : IntSetSet.t =
189: fold_left
190: (fun x (_,k) -> match k with
191: | `Nonterm ii -> IntSetSet.add (set_of_list ii) x
192: | `Term _ -> x
193: )
194: IntSetSet.empty
195: p
196: in
197: let prod_of_glr i =
198: try
199: match Hashtbl.find bbdfns i with
200: | _,_,_,`BBDCL_glr (_,_,_,(p,_)) -> p
201: | id,_,_,entry -> failwith
202: ("Expected "^si i^"->BBDCL_glr, got " ^ string_of_bbdcl syms.dfns entry i)
203:
204: with Not_found -> failwith ("Can't find BBDCL_glr " ^ si i)
205: in
206: let nts_of_glr i : IntSetSet.t = nts_of_prod (prod_of_glr i) in
207: let nt_uses x : IntSetSet.t =
208: IntSet.fold
209: (fun i nts ->
210: IntSetSet.union nts (nts_of_glr i)
211: )
212: x
213: IntSetSet.empty
214: in
215: let make_closure ii =
216: let been_done = ref (IntSetSet.singleton (set_of_list ii)) in
217: let to_do = ref (nt_uses (set_of_list ii)) in
218: while not (IntSetSet.is_empty !to_do) do
219: let x = IntSetSet.choose !to_do in
220: to_do := IntSetSet.remove x !to_do;
221: if not (IntSetSet.mem x !been_done) then begin
222: been_done := IntSetSet.add x !been_done;
223: to_do := IntSetSet.union !to_do (nt_uses x)
224: end
225: done;
226: !been_done
227: in
228: let print_nonterm x =
229: let j = IntSet.choose x in
230: let id,parent,sr'',entry = Hashtbl.find bbdfns j in
231: begin match entry with
232: | `BBDCL_glr (_,_,t,(p,xs)) ->
233: let tt = tn t in
234: pe ("nonterm("^tt^"*) "^cid_of_flxid id^" {");
235: pe (" fun dup(x) { return new " ^ tt ^ "(*x); }");
236: pe (" fun del(x) { delete x; }");
237: IntSet.iter (fun i ->
238: let id,parent,sr'',entry = Hashtbl.find bbdfns i in
239: match entry with
240: | `BBDCL_glr (_,_,t,(p,xs)) -> print_production (i,p,xs)
241: | _ -> assert false
242: )
243: x;
244: pe "}";
245: | _ -> assert false
246: end
247: in
248: let display = cal_display bbdfns (Some this) in
249: let frame_dcls =
250: " FLX_FMEM_DECL"
251: in
252: let display_string =
253: cat ""
254: (
255: map
256: (fun (i,vslen) ->
257: try
258: let instname = cpp_instance_name syms bbdfns i [] in
259: " " ^ instname ^ " *ptr" ^ instname ^ ";\n"
260: with _ -> failwith "Can't cal display name"
261: )
262: display
263: )
264: and ctor_dcl =
265: " Elk" ^parser_name^
266: (if length display = 0
267: then "(FLX_FPAR_DECL_ONLY);\n"
268: else (
269: " (\n" ^
270: " FLX_FPAR_DECL\n " ^
271: cat ",\n"
272: (
273: map
274: (
275: fun (i,vslen) ->
276: let instname = cpp_instance_name syms bbdfns i [] in
277: " " ^ instname ^ "*"
278: )
279: display
280: )^
281: "\n );\n"
282: ))
283: in
284: begin match t' with
285: | `BTYP_function (`BTYP_tuple [],`BTYP_inst(i,[])) ->
286: let token_id,parent,sr',entry = Hashtbl.find bbdfns i in
287: let token_type = `BTYP_inst(i,[]) in
288: let token_type_name = tn token_type in
289: begin match entry with
290: | `BBDCL_union ([],cts) ->
291: let j = hd ii in
292: let id,parent,sr'',entry = Hashtbl.find bbdfns j in
293: begin match entry with
294: | `BBDCL_glr (props,_,t,(p,xs)) ->
295: let result_type = tn t in
296: pe ("//Elkhound parser Elk" ^ parser_name ^ " -> " ^ result_type);
297: pe ("//Token type " ^ token_id ^ " -> " ^ token_type_name);
298: pe "terminals {";
299: let i = ref 0 in
300: iter (fun (id,j,t) ->
301: pe (" " ^ si j^" : "^ cid_of_flxid id ^ ";")
302: )
303: cts;
304:
305: pe "";
306: iter (fun (id,_,t) ->
307: if t <> `BTYP_void then begin
308: pe (" token("^tn t^"*) " ^ cid_of_flxid id ^ "{");
309: pe (" fun dup(x) { return x; }");
310: pe (" fun del(x) {}");
311: pe ("}");
312: end
313: )
314: cts;
315:
316: pe "}";
317: pe "";
318: pe ("context_class Elk"^parser_name^": public UserActions {");
319: pe ("public:");
320: pe frame_dcls;
321: ps display_string;
322: pe ctor_dcl;
323: pe (" collector_t &gc;");
324: pe
325: (
326: (if t = `BTYP_tuple [] then "int" else "_uctor_") ^
327: " apply(LexerInterface *lex);"
328: );
329: pe "};";
330: pe "";
331: pe "impl_verbatim {";
332: pe (gen_ctor syms bbdfns ("Elk"^parser_name) display [] [] ["gc(*PTF gc)"] [] props);
333: pe "}";
334: pe "";
335: pe "impl_verbatim {";
336: pe "// Felix function to apply the parser to a lexer";
337: pe "// This returns a polymorphic option";
338: pe "// case 0- Parse failed";
339: pe "// case 1- Argument contains parser result";
340: pe ("// Type of parser result is " ^ sbt syms.dfns t);
341:
342: pe
343: (
344: (if t = `BTYP_tuple [] then "int" else "_uctor_") ^
345: " Elk"^parser_name^"::apply(LexerInterface *lex) {"
346: );
347: pe " _uctor_ result(0,0);";
348: pe " SemanticValue p=(SemanticValue)(void*)0;";
349: pe " GLR glr(this,this->makeTables());";
350: pe " glr.noisyFailedParse = true;";
351: pe " result.variant = glr.glrParse(*lex,p);";
352: pe "";
353: pe " if(result.variant==1)";
354:
355: if t = `BTYP_tuple [] then begin
356: pe " delete (void*)p;";
357: pe " return result.variant;";
358: end else begin
359: pe (" result.data =");
360: pe (" new(gc,"^shape_of bbdfns tn t^")");
361: pe (" "^result_type^"(*("^result_type^"*)(void*)p)");
362: pe (" ;");
363: pe " delete (void*)p;";
364: pe " return result;";
365: end;
366: pe "}";
367: pe "}";
368: pe "";
369:
370: pe ("nonterm("^result_type^"*) elk"^parser_name^" {");
371: print_production (j,p,xs);
372: iter (fun i ->
373: let id,parent,sr'',entry = Hashtbl.find bbdfns i in
374: match entry with
375: | `BBDCL_glr (_,vs,t,(p,xs)) -> print_production (i,p,xs)
376: | _ -> assert false
377: )
378: (tl ii)
379: ;
380: pe "}";
381: let cls = make_closure ii in
382: IntSetSet.iter print_nonterm cls;
383: pe "//End grammar"
384:
385: | _ -> assert false (* must be glr *)
386: end
387:
388: | _ ->
389: clierr sr
390: "Parser function must have unit domain and return a non-polymorphic union"
391: end
392: | _ ->
393: clierr sr
394: "Parser function must have unit domain and return a non-polymorphic union"
395: end
396: ;
397: close_out f
398: ;
399: let elkhound = syms.compiler_options.elkhound in
400: let retval = Unix.system(elkhound ^ " -tr nolines " ^ filename) in
401: begin match retval with
402: | Unix.WEXITED 0 -> ()
403: | _ -> failwith "Error executing flx_elkhound"
404: end
405:
406:
//@head(1,'C++ Code generator')
Start ocaml section to src/flx_gen.mli[1
/1
]
1: # 4 "./lpsrc/flx_gen.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_mtypes1
5: open Flx_mtypes2
6: open Flx_label
7:
8: val gen_functions:
9: sym_state_t ->
10: (bid_t, bid_t list) Hashtbl.t *
11: fully_bound_symbol_table_t ->
12: string
13:
14: val gen_execute_methods:
15: string ->
16: sym_state_t ->
17: (bid_t, bid_t list) Hashtbl.t *
18: fully_bound_symbol_table_t ->
19: label_map_t * label_usage_t ->
20: int ref ->
21: out_channel ->
22: unit
23:
24: val find_members:
25: sym_state_t ->
26: (bid_t, bid_t list) Hashtbl.t *
27: fully_bound_symbol_table_t ->
28: int ->
29: btypecode_t list ->
30: string
31:
32: val gen_biface_headers:
33: sym_state_t ->
34: fully_bound_symbol_table_t ->
35: biface_t list ->
36: string
37:
38: val gen_biface_bodies:
39: sym_state_t ->
40: fully_bound_symbol_table_t ->
41: biface_t list ->
42: string
43:
44: val format_vars:
45: sym_state_t ->
46: fully_bound_symbol_table_t ->
47: bid_t list ->
48: btypecode_t list ->
49: string
50:
51: val is_gc_pointer:
52: sym_state_t ->
53: fully_bound_symbol_table_t ->
54: range_srcref ->
55: btypecode_t ->
56: bool
57:
Start ocaml section to src/flx_gen.ml[1
/1
]
1: # 62 "./lpsrc/flx_gen.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_name
10: open Flx_tgen
11: open Flx_unify
12: open Flx_csubst
13: open Flx_exceptions
14: open Flx_display
15: open List
16: open Flx_generic
17: open Flx_label
18: open Flx_unravel
19: open Flx_ogen
20: open Flx_ctypes
21: open Flx_cexpr
22: open Flx_maps
23: open Flx_egen
24: open Flx_pgen
25: open Flx_ctorgen
26: open Flx_child
27: open Flx_beta
28:
29: let find_variable_indices syms (child_map,bbdfns) index =
30: let children = find_children child_map index in
31: filter
32: (fun i ->
33: try match Hashtbl.find bbdfns i with _,_,_,entry ->
34: match entry with
35: | `BBDCL_var _
36: | `BBDCL_val _ -> true
37: | _ -> false
38: with Not_found -> false
39: )
40: children
41:
42: let get_variable_typename syms bbdfns i ts =
43: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
44: let id,parent,sr,entry =
45: try Hashtbl.find bbdfns i
46: with Not_found -> failwith ("[get_variable_typename] can't find index " ^ si i)
47: in
48: match entry with
49: | `BBDCL_var (vs,t)
50: | `BBDCL_val (vs,t)
51: | `BBDCL_tmp (vs,t)
52: ->
53: let t = lower t in
54: if length ts <> length vs then
55: failwith
56: (
57: "[get_variable_typename} wrong number of args, expected vs = " ^
58: si (length vs) ^
59: ", got ts=" ^
60: si (length ts)
61: );
62: let t = rt vs t in
63: let n = cpp_typename syms t in
64: n
65:
66: | _ ->
67: failwith "[get_variable_typename] Expected variable"
68:
69: let format_vars syms bbdfns vars ts =
70: catmap ""
71: (fun idx ->
72: let instname =
73: try Some (cpp_instance_name syms bbdfns idx ts)
74: with _ -> None
75: in
76: match instname with
77: | Some instname ->
78: let typename = get_variable_typename syms bbdfns idx ts in
79: " " ^ typename ^ " " ^ instname ^ ";\n"
80: | None -> "" (* ignore unused variables *)
81: )
82: vars
83:
84: let find_members syms (child_map,bbdfns) index ts =
85: let variables = find_variable_indices syms (child_map,bbdfns) index in
86: match format_vars syms bbdfns variables ts with
87: | "" -> ""
88: | x ->
89: (*
90: " //variables\n" ^
91: *)
92: x
93:
94: let typeof_bparams ps: btypecode_t =
95: typeoflist
96: (map
97: (fun (id,(ix,t)) ->t)
98: ps
99: )
100:
101: let get_type bbdfns index =
102: let id,parent,sr,entry =
103: try Hashtbl.find bbdfns index
104: with _ -> failwith ("[get_type] Can't find index " ^ si index)
105: in
106: match entry with
107: | `BBDCL_function (props,vs,(ps,_),ret,_) ->
108: `BTYP_function (typeof_bparams ps,ret)
109: | `BBDCL_procedure (props,vs,(ps,_),_) ->
110: `BTYP_function (typeof_bparams ps,`BTYP_void)
111: | _ -> failwith "Only function and procedure types handles by get_type"
112:
113:
114: let is_gc_pointer syms bbdfns sr t =
115: let t = lstrip syms.dfns t in
116: (*
117: print_endline ("[is_gc_ptr] Checking type " ^ sbt syms.dfns t);
118: *)
119: match t with
120: | `BTYP_function _ -> true
121: | `BTYP_inst (i,_) ->
122: let id,sr,parent,entry =
123: try Hashtbl.find bbdfns i
124: with Not_found ->
125: clierr sr ("[is_gc_pointer] Can't find nominal type " ^ si i);
126: in
127: begin match entry with
128: | `BBDCL_abs (_,tqs,_,_) -> mem `GC_pointer tqs
129: | _ -> false
130: end
131: | _ -> false
132:
133: let gen_C_function syms (child_map,bbdfns) props index id vs bps ret' ts instance_no =
134: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
135: let requires_ptf = mem `Requires_ptf props in
136: let ps = map (fun (id,(ix,t)) -> id,t) bps in
137: let params = map (fun (id,(ix,t)) -> ix) bps in
138: if syms.compiler_options.print_flag then
139: print_endline
140: (
141: "//Generating C function inst " ^
142: si instance_no ^ "=" ^
143: id ^ "<" ^si index^">" ^
144: (
145: if length ts = 0 then ""
146: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
147: )
148: );
149: let argtype = lower(typeof_bparams bps) in
150: if length ts <> length vs then
151: failwith
152: (
153: "[gen_function} wrong number of args, expected vs = " ^
154: si (length vs) ^
155: ", got ts=" ^
156: si (length ts)
157: );
158: let argtype = rt vs argtype in
159: let rt' vs t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
160: let ret = rt' vs ret' in
161: let is_ref = match ret with `BTYP_lvalue _ -> true | _ -> false in
162: let ret = lstrip syms.dfns ret in
163: if ret = `BTYP_tuple [] then "// elided (returns unit)\n" else
164:
165: let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
166:
167: let argtypename = cpp_typename syms argtype in
168: let display = get_display_list bbdfns index in
169: assert (length display = 0);
170: let name = cpp_instance_name syms bbdfns index ts in
171: let rettypename = cpp_typename syms ret in
172: rettypename ^ " " ^
173: (if is_ref then "& " else "") ^
174: "FLX_REGPARM "^
175: name ^ "(" ^
176: (
177: let s =
178: match length params with
179: | 0 -> ""
180: | 1 ->
181: let ix = hd params in
182: if Hashtbl.mem syms.instances (ix, ts)
183: && not (argtype = `BTYP_tuple [])
184: then argtypename else ""
185: | _ ->
186: let counter = ref 0 in
187: fold_left
188: (fun s (_,(i,t)) ->
189: let t = rt vs (lower t) in
190: if Hashtbl.mem syms.instances (i,ts) && not (t = `BTYP_tuple [])
191: then s ^
192: (if String.length s > 0 then ", " else " ") ^
193: cpp_typename syms t
194: else s (* elide initialisation of elided variable *)
195: )
196: ""
197: bps
198: in
199: (
200: if String.length s > 0
201: then (if requires_ptf then "FLX_FPAR_DECL " else "") ^s
202: else (if requires_ptf then "FLX_FPAR_DECL_ONLY" else "")
203: )
204: ) ^
205: ");\n"
206:
207: let gen_class syms (child_map,bbdfns) props index id vs ts instance_no =
208: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
209: let requires_ptf = mem `Requires_ptf props in
210: if syms.compiler_options.print_flag then
211: print_endline
212: (
213: "//Generating class inst " ^
214: si instance_no ^ "=" ^
215: id ^ "<" ^si index^">" ^
216: (
217: if length ts = 0 then ""
218: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
219: )
220: );
221: if length ts <> length vs then
222: failwith
223: (
224: "[gen_function} wrong number of args, expected vs = " ^
225: si (length vs) ^
226: ", got ts=" ^
227: si (length ts)
228: );
229: let display = get_display_list bbdfns index in
230: let frame_dcls =
231: if requires_ptf then
232: " FLX_FMEM_DECL\n"
233: else ""
234: in
235: let display_string = match display with
236: | [] -> ""
237: | display ->
238: cat ""
239: (
240: map
241: (fun (i, vslen) ->
242: try
243: let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
244: " " ^ instname ^ " *ptr" ^ instname ^ ";\n"
245: with _ -> failwith "Can't cal display name"
246: )
247: display
248: )
249: and ctor_dcl name =
250: " " ^name^
251: (if length display = 0
252: then (if requires_ptf then "(FLX_FPAR_DECL_ONLY);\n" else "();\n")
253: else (
254: " (" ^
255: (if requires_ptf then
256: "FLX_FPAR_DECL "
257: else ""
258: )
259: ^
260: cat ","
261: (
262: map
263: (
264: fun (i,vslen) ->
265: let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
266: instname ^ "*"
267: )
268: display
269: )^
270: ");\n"
271: ))
272: (*
273: and dtor_dcl name =
274: " ~" ^ name ^"();\n"
275: *)
276: in
277: let members = find_members syms (child_map,bbdfns) index ts in
278: let name = cpp_instance_name syms bbdfns index ts in
279: let ctor = ctor_dcl name in
280: "struct " ^ name ^
281: " {\n" ^
282: (*
283: " //os frames\n" ^
284: *)
285: frame_dcls ^
286: (*
287: " //display\n" ^
288: *)
289: (
290: if String.length display_string = 0 then "" else
291: display_string ^ "\n"
292: )
293: ^
294: members ^
295: (*
296: " //constructor\n" ^
297: *)
298: ctor ^
299: (
300: if mem `Heap_closure props then
301: (*
302: " //clone\n" ^
303: *)
304: " " ^name^"* clone()const;\n"
305: else ""
306: )
307: ^
308: (*
309: " //call\n" ^
310: *)
311: "};\n"
312:
313:
314: (* vs here is the (name,index) list of type variables *)
315: let gen_function syms (child_map,bbdfns) props index id vs bps ret' ts instance_no =
316: let stackable = mem `Stack_closure props in
317: let heapable = mem `Heap_closure props in
318: let heapable = not stackable or heapable in
319: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
320: let requires_ptf = mem `Requires_ptf props in
321: (*
322: print_endline ("The function " ^ id ^ (if requires_ptf then " REQUIRES PTF" else "DOES NOT REQUIRE PTF"));
323: *)
324: let ps = map (fun (id,(ix,t)) -> id,t) bps in
325: if syms.compiler_options.print_flag then
326: print_endline
327: (
328: "//Generating function inst " ^
329: si instance_no ^ "=" ^
330: id ^ "<" ^si index^">" ^
331: (
332: if length ts = 0 then ""
333: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
334: )
335: );
336: let argtype = lower(typeof_bparams bps) in
337: if length ts <> length vs then
338: failwith
339: (
340: "[gen_function} wrong number of args, expected vs = " ^
341: si (length vs) ^
342: ", got ts=" ^
343: si (length ts)
344: );
345: let argtype = rt vs argtype in
346: let rt' vs t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
347: let ret = rt' vs ret' in
348: let is_ref = match ret with | `BTYP_lvalue _ -> true | _ -> false in
349: let ret = lstrip syms.dfns ret in
350: if ret = `BTYP_tuple [] then "// elided (returns unit)\n" else
351:
352: let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
353:
354: let argtypename = cpp_typename syms argtype in
355: let funtypename =
356: if mem `Heap_closure props then
357: try Some (cpp_type_classname syms funtype)
358: with _ -> None
359: else None
360: in
361: let display = get_display_list bbdfns index in
362: let frame_dcls =
363: if requires_ptf then
364: " FLX_FMEM_DECL\n"
365: else ""
366: in
367: let display_string = match display with
368: | [] -> ""
369: | display ->
370: cat ""
371: (
372: map
373: (fun (i, vslen) ->
374: try
375: let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
376: " " ^ instname ^ " *ptr" ^ instname ^ ";\n"
377: with _ -> failwith "Can't cal display name"
378: )
379: display
380: )
381: and ctor_dcl name =
382: " " ^name^
383: (if length display = 0
384: then (if requires_ptf then "(FLX_FPAR_DECL_ONLY);\n" else "();\n")
385: else (
386: " (" ^
387: (if requires_ptf then
388: "FLX_FPAR_DECL "
389: else ""
390: )
391: ^
392: cat ", "
393: (
394: map
395: (
396: fun (i,vslen) ->
397: let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
398: instname ^ "*"
399: )
400: display
401: )^
402: ");\n"
403: ))
404: (*
405: and dtor_dcl name =
406: " ~" ^ name ^"();\n"
407: *)
408: in
409: let members = find_members syms (child_map,bbdfns) index ts in
410: match ret with
411: | `BTYP_void ->
412: let name = cpp_instance_name syms bbdfns index ts in
413: let ctor = ctor_dcl name in
414: "struct " ^ name ^
415: (match funtypename with
416: | Some x -> ": "^x
417: | None -> if not heapable then "" else ": con_t"
418: )
419: ^
420: " {\n" ^
421: (*
422: " //os frames\n" ^
423: *)
424: frame_dcls ^
425: (*
426: " //display\n" ^
427: *)
428: display_string ^ "\n" ^
429: members ^
430: (*
431: " //constructor\n" ^
432: *)
433: ctor ^
434: (
435: if mem `Heap_closure props then
436: (*
437: " //clone\n" ^
438: *)
439: " " ^name^"* clone()const;\n"
440: else ""
441: )
442: ^
443: (*
444: " //call\n" ^
445: *)
446: (if argtype = `BTYP_tuple []
447: then
448: (if stackable then " void stack_call();\n" else "") ^
449: (if heapable then " con_t *call(con_t*);\n" else "")
450: else
451: (if stackable then " void stack_call("^argtypename^" const &);\n" else "") ^
452: (if heapable then " con_t *call(con_t*,"^argtypename^" const &);\n" else "")
453: ) ^
454: (*
455: " //resume\n" ^
456: *)
457: (if heapable then " con_t *resume();\n" else "")
458: ^
459: "};\n"
460:
461: | _ ->
462: let name = cpp_instance_name syms bbdfns index ts in
463: let rettypename = cpp_typename syms ret in
464: let ctor = ctor_dcl name in
465: "struct " ^ name ^
466: (match funtypename with
467: | Some x -> ": "^x
468: | None -> ""
469: )
470: ^
471: " {\n" ^
472: (*
473: " //os frames\n" ^
474: *)
475: frame_dcls ^
476: (*
477: " //display\n" ^
478: *)
479: display_string ^ "\n" ^
480: members ^
481: (*
482: " //constructor\n" ^
483: *)
484: ctor ^
485: (
486: if mem `Heap_closure props then
487: (*
488: " //clone\n" ^
489: *)
490: " " ^name^"* clone()const;\n"
491: else ""
492: )
493: ^
494: (*
495: " //apply\n" ^
496: *)
497: " "^rettypename^
498: (if is_ref then "& " else "") ^
499: " apply(" ^
500: (if argtype = `BTYP_tuple[] then ""
501: else argtypename^" const &")^
502: ");\n" ^
503: "};\n"
504:
505:
506: (* This code generates the class declarations *)
507: let gen_functions syms (child_map,bbdfns) =
508: let xxdfns = ref [] in
509: Hashtbl.iter
510: (fun x i ->
511: (* if proper_descendant syms.dfns parent then *)
512: xxdfns := (i,x) :: !xxdfns
513: )
514: syms.instances
515: ;
516:
517: let s = Buffer.create 2000 in
518: iter
519: (fun (i,(index,ts)) ->
520: let tss =
521: if length ts = 0 then "" else
522: "[" ^ catmap "," (string_of_btypecode syms.dfns) ts^ "]"
523: in
524: match
525: try Hashtbl.find bbdfns index
526: with Not_found -> failwith ("[gen_functions] can't find index " ^ si index)
527: with (id,parent,sr,entry) ->
528: match entry with
529: | `BBDCL_function (props,vs,(ps,traint), ret, _) ->
530: bcat s ("\n//------------------------------\n");
531: if mem `Pure props && not (mem `Heap_closure props) then begin
532: bcat s ("//PURE C FUNCTION " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
533: bcat s
534: (gen_C_function syms (child_map,bbdfns) props index id vs ps ret ts i)
535: end else begin
536: bcat s ("//FUNCTION " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
537: bcat s
538: (gen_function syms (child_map,bbdfns) props index id vs ps ret ts i)
539: end
540:
541: | `BBDCL_callback (props,vs,ps_cf,ps_c,_,ret',_,_) ->
542: let instance_no = i in
543: bcat s ("\n//------------------------------\n");
544: if ret' = `BTYP_void then begin
545: bcat s ("//CALLBACK C PROC " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
546: end else begin
547: bcat s ("//CALLBACK C FUNCTION " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
548: end
549: ;
550: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
551: if syms.compiler_options.print_flag then
552: print_endline
553: (
554: "//Generating C callback function inst " ^
555: si instance_no ^ "=" ^
556: id ^ "<" ^si index^">" ^
557: (
558: if length ts = 0 then ""
559: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
560: )
561: );
562: if length ts <> length vs then
563: failwith
564: (
565: "[gen_function} wrong number of args, expected vs = " ^
566: si (length vs) ^
567: ", got ts=" ^
568: si (length ts)
569: );
570: let ret = rt vs ret' in
571: (*
572: let name = cpp_instance_name syms bbdfns index ts in
573: *)
574: let name = id in (* callbacks can't be polymorphic .. for now anyhow *)
575: let rettypename = cpp_typename syms ret in
576: let sss =
577: "extern \"C\" " ^
578: rettypename ^ " " ^
579: name ^ "(" ^
580: (
581: match length ps_c with
582: | 0 -> ""
583: | 1 -> cpp_typename syms (hd ps_c)
584: | _ ->
585: fold_left
586: (fun s t ->
587: let t = rt vs (lower t) in
588: s ^
589: (if String.length s > 0 then ", " else "") ^
590: cpp_typename syms t
591: )
592: ""
593: ps_c
594: ) ^
595: ");\n"
596: in bcat s sss
597:
598: | `BBDCL_procedure (props,vs,(ps,traint),_) ->
599: bcat s ("\n//------------------------------\n");
600: if mem `Pure props && not (mem `Heap_closure props) then begin
601: bcat s ("//PURE C PROC " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
602: bcat s
603: (gen_C_function syms (child_map,bbdfns) props index id vs ps `BTYP_void ts i)
604: end else begin
605: bcat s ("//PROC " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
606: bcat s
607: (gen_function syms (child_map,bbdfns) props index id vs ps `BTYP_void ts i)
608: end
609:
610: | `BBDCL_regmatch (props,vs, (ps,traint), ret, regargs) ->
611: bcat s ("\n//------------------------------\n");
612: bcat s ("//REGMATCH " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
613: bcat s
614: (gen_function syms (child_map,bbdfns) props index id vs ps ret ts i)
615:
616: | `BBDCL_reglex (props, vs, (ps,traint), i, ret, regargs) ->
617: bcat s ("\n//------------------------------\n");
618: bcat s ("//REGLEX " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
619: bcat s
620: (gen_function syms (child_map,bbdfns) props index id vs ps ret ts i)
621:
622: | `BBDCL_class (props,vs) ->
623: bcat s ("\n//------------------------------\n");
624: bcat s ("//CLASS " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
625: let t = `BTYP_inst (index,ts) in
626: let j = try
627: Hashtbl.find syms.registry t with
628: Not_found -> failwith "Cannot find class type instance in type registry"
629: in
630: bcat s ("//CLASS " ^ si index ^ ", OBJECT INSTANCE " ^ si i ^ " TYPE INSTANCE " ^ si j ^ "\n");
631: bcat s
632: (gen_class syms (child_map,bbdfns) props index id vs ts i)
633:
634: | _ -> () (* bcat s ("//SKIPPING " ^ id ^ "\n") *)
635: )
636: (sort compare !xxdfns)
637: ;
638: Buffer.contents s
639:
640: (*
641: let gen_dtor syms bbdfns name display ts =
642: name^"::~"^name^"(){}\n"
643: *)
644: let is_closure_var bbdfns index =
645: let var_type bbdfns index =
646: let id,_,entry =
647: try Hashtbl.find bbdfns index
648: with Not_found -> failwith ("[var_type] ]Can't get index " ^ si index)
649: in match entry with
650: | `BBDCL_var (_,t)
651: | `BBDCL_val (_,t) -> lower t
652: | _ -> failwith ("[var_type] expected "^id^" to be variable")
653: in
654: match var_type bbdfns index with
655: | `BTYP_function _ -> true
656: | _ -> false
657:
658: (* NOTE: it isn't possible to pass an explicit tuple as a single
659: argument to a primitive, nor a single value of tuple/array type.
660: In the latter case a cast/abstraction can defeat this, for the
661: former you'll need to make a dummy variable.
662: *)
663:
664:
665:
666: type kind_t = Function | Procedure
667:
668: let gen_exe filename syms
669: (child_map,bbdfns) (label_map,label_usage_map)
670: counter this vs ts instance_no needs_switch stackable (exe:bexe_t) : string =
671: if length ts <> length vs then
672: failwith
673: (
674: "[gen_exe} wrong number of args, expected vs = " ^
675: si (length vs) ^
676: ", got ts=" ^
677: si (length ts)
678: );
679: let sr = ("dummy",0,0,0,0) in
680: let src_str = string_of_bexe syms.dfns 0 exe in
681: let with_comments = syms.compiler_options.with_comments in
682: (*
683: print_endline ("generating exe " ^ string_of_bexe syms.dfns 0 exe);
684: print_endline ("vs = " ^ catmap "," (fun (s,i) -> s ^ "->" ^ si i) vs);
685: print_endline ("ts = " ^ catmap "," (string_of_btypecode syms.dfns) ts);
686: *)
687: let tsub t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
688: let ge sr e : string = gen_expr syms bbdfns this e vs ts sr in
689: let ge' sr e : cexpr_t = gen_expr' syms bbdfns this e vs ts sr in
690: let tn t : string = cpp_typename syms (tsub t) in
691: let id,parent,sr,entry =
692: try Hashtbl.find bbdfns this
693: with _ -> failwith ("[gen_exe] Can't find this " ^ si this)
694: in
695: let our_display = get_display_list bbdfns this in
696: let kind = match entry with
697: | `BBDCL_function (_,_,_,_,_) -> Function
698: | `BBDCL_procedure (_,_,_,_) -> Procedure
699: | _ -> failwith "Expected executable code to be in function or procedure"
700: in let our_level = length our_display in
701:
702: let handle_closure sr is_jump index ts subs a stack_call =
703: let subs =
704: catmap ""
705: (fun ((_,t) as e,s) ->
706: let t = cpp_ltypename syms t in
707: let e = ge sr e in
708: " " ^ t ^ " " ^ s ^ " = " ^ e ^ ";\n"
709: )
710: subs
711: in
712: let sub_start =
713: if String.length subs = 0 then ""
714: else " {\n" ^ subs
715: and sub_end =
716: if String.length subs = 0 then ""
717: else " }\n"
718: in
719: let id,parent,sr2,entry =
720: try Hashtbl.find bbdfns index
721: with _ -> failwith ("[gen_exe(call)] Can't find index " ^ si index)
722: in
723: begin
724: match entry with
725: | `BBDCL_proc (props,vs,_,ct,_) ->
726: assert (not is_jump);
727:
728: if length vs <> length ts then
729: clierr sr "[gen_prim_call] Wrong number of type arguments"
730: ;
731: let s =
732: match ct with
733: | `Str s -> ce_expr "expr" s
734: | `StrTemplate s ->
735: gen_prim_call syms bbdfns tsub ge' s ts a "Error" sr sr2 "atom"
736: in
737: let s = sc "expr" s in
738: (if with_comments then " // " ^ src_str ^ "\n" else "") ^
739: sub_start ^
740: " " ^ s ^ "\n" ^
741: sub_end
742:
743: | `BBDCL_callback (props,vs,ps_cf,ps_c,_,ret,_,_) ->
744: assert (not is_jump);
745: assert (ret = `BTYP_void);
746:
747: if length vs <> length ts then
748: clierr sr "[gen_prim_call] Wrong number of type arguments"
749: ;
750: let s = id ^ "($a);" in
751: let s =
752: gen_prim_call syms bbdfns tsub ge' s ts a "Error" sr sr2 "atom"
753: in
754: let s = sc "expr" s in
755: (if with_comments then " // " ^ src_str ^ "\n" else "") ^
756: sub_start ^
757: " " ^ s ^ "\n" ^
758: sub_end
759:
760:
761: | `BBDCL_procedure (props,vs,ps,bexes) ->
762: if bexes = []
763: then
764: " //call to empty procedure " ^ id ^ " elided\n"
765: else begin
766: let n = !counter in
767: incr counter;
768: let the_display =
769: let d' =
770: map (fun (i,vslen) -> "ptr"^cpp_instance_name syms bbdfns i (list_prefix ts vslen))
771: (get_display_list bbdfns index)
772: in
773: if length d' > our_level
774: then "this" :: tl d'
775: else d'
776: in
777: (* if we're calling from inside a function,
778: we pass a 0 continuation as the caller 'return address'
779: otherwise pass 'this' as the caller 'return address'
780: EXCEPT that stack calls don't pass a return address at all
781: *)
782: let this = match kind with
783: | Function ->
784: if is_jump
785: then
786: clierr sr "can't jump inside function"
787: else if stack_call then ""
788: else "0"
789:
790: | Procedure ->
791: if stack_call then "" else
792: if is_jump then "tmp"
793: else "this"
794: in
795:
796: let args = match a with
797: | _,`BTYP_tuple [] -> this
798: | _ ->
799: (
800: let a = ge sr a in
801: if this = "" then a else this ^ ", " ^ a
802: )
803: in
804: let name = cpp_instance_name syms bbdfns index ts in
805: if stack_call then begin
806: (*
807: print_endline "GENERATING STACK CALL";
808: *)
809: (if with_comments
810: then " //run procedure " ^ src_str ^ "\n"
811: else "") ^
812: " {\n" ^
813: subs ^
814: " " ^ name ^ strd the_display props^ "\n" ^
815: " .stack_call(" ^ args ^ ");\n" ^
816: " }\n"
817: end
818: else
819: let ptrmap = name ^ "_ptr_map" in
820: begin
821: match kind with
822: | Function ->
823: (if with_comments
824: then " //run procedure " ^ src_str ^ "\n"
825: else "") ^
826: " {\n" ^
827: subs ^
828: " con_t *_p =\n" ^
829: " (FLX_NEWP(" ^ name ^ ")" ^ strd the_display props^ ")\n" ^
830: " ->call(" ^ args ^ ");\n" ^
831: " while(_p) _p=_p->resume();\n" ^
832: " }\n"
833:
834: | Procedure ->
835: let call_string =
836: " return (FLX_NEWP(" ^ name ^ ")"^strd the_display props ^ ")" ^
837: "\n ->call(" ^ args ^ ");\n"
838: in
839: if is_jump
840: then
841: (if with_comments then
842: " //jump to procedure " ^ src_str ^ "\n"
843: else "") ^
844: " {\n" ^
845: subs ^
846: " con_t *tmp = _caller;\n" ^
847: " _caller = 0;\n" ^
848: call_string ^
849: " }\n"
850: else
851: (
852: needs_switch := true;
853: (if with_comments then
854: " //call procedure " ^ src_str ^ "\n"
855: else ""
856: )
857: ^
858:
859: sub_start ^
860: " FLX_SET_PC(" ^ si n ^ ")\n" ^
861: call_string ^
862: sub_end ^
863: " FLX_CASE_LABEL(" ^ si n ^ ")\n"
864: )
865: end
866: end
867:
868: | _ ->
869: failwith
870: (
871: "[gen_exe] Expected '"^id^"' to be procedure constant, got " ^
872: string_of_bbdcl syms.dfns entry index
873: )
874: end
875: in
876: let gen_nonlocal_goto pc frame s =
877: (* WHAT THIS CODE DOES: we pop the call stack until
878: we find the first ancestor containing the target label,
879: set the pc there, and return its continuation to the
880: driver; we know the address of this frame because
881: it must be in this function's display.
882: *)
883: let target_instance =
884: try Hashtbl.find syms.instances (frame, ts)
885: with Not_found -> failwith "Woops, bugged code, wrong type arguments for instance?"
886: in
887: let frame_ptr = "ptr" ^ cpp_instance_name syms bbdfns frame ts in
888: " // non local goto " ^ s ^ "\n" ^
889: " {\n" ^
890: " con_t *tmp1 = this;\n" ^
891: " while(tmp1 && " ^ frame_ptr ^ "!= tmp1)\n" ^
892: " {\n" ^
893: " con_t *tmp2 = tmp1->_caller;\n" ^
894: " tmp1 -> _caller = 0;\n" ^
895: " tmp1 = tmp2;\n" ^
896: " }\n" ^
897: " }\n" ^
898: " " ^ frame_ptr ^ "->pc = FLX_FARTARGET("^si pc^","^si target_instance^","^s^");\n" ^
899: " return " ^ frame_ptr ^ ";\n"
900: in
901: let forget_template s = match s with | `Str s -> s | `StrTemplate s -> s in
902: let rec gexe exe =
903: (*
904: print_endline (string_of_bexe syms.dfns 0 exe);
905: *)
906: match exe with
907: | `BEXE_axiom_check _ -> assert false
908: | `BEXE_code (_,s) -> forget_template s
909: | `BEXE_nonreturn_code (_,s) -> forget_template s
910: | `BEXE_comment (_,s) -> "/*" ^ s ^ "*/\n"
911: | `BEXE_label (_,s) ->
912: let local_labels =
913: try Hashtbl.find label_map this
914: with _ -> failwith ("[gen_exe] Can't find label map of " ^ si this)
915: in
916: let label_index =
917: try Hashtbl.find local_labels s
918: with _ -> failwith ("[gen_exe] In " ^ id ^ ": Can't find label " ^ s)
919: in
920: let label_kind = get_label_kind_from_index label_usage_map label_index in
921: (match kind with
922: | Procedure ->
923: begin match label_kind with
924: | `Far ->
925: needs_switch := true;
926: " FLX_LABEL(" ^ si label_index ^ ","^si instance_no ^","^s^")\n"
927: | `Near ->
928: " " ^ s ^ ":;\n"
929: | `Unused -> ""
930: end
931:
932: | Function ->
933: begin match label_kind with
934: | `Far -> assert false
935: | `Near ->
936: " " ^ s ^ ":;\n"
937: | `Unused -> ""
938: end
939: )
940:
941: (* FIX THIS TO PUT SOURCE REFERENCE IN *)
942: | `BEXE_halt (sr,s) ->
943: " // halt " ^ s ^ "\n" ^
944: " throw flx::rtl::flx_exec_failure_t(\n" ^
945: " \"" ^ Flx_srcref.short_string_of_src sr ^ "\",\n" ^
946: " \"halt\",\n" ^
947: " \"" ^ s ^ "\"\n" ^
948: " );\n"
949:
950: | `BEXE_goto (sr,s) ->
951: begin match find_label bbdfns label_map this s with
952: | `Local _ -> " goto " ^ s ^ ";\n"
953: | `Nonlocal (pc,frame) -> gen_nonlocal_goto pc frame s
954: | `Unreachable ->
955: clierr sr ("Jump to unreachable label " ^ s)
956: end
957:
958: | `BEXE_ifgoto (sr,e,s) ->
959: begin match find_label bbdfns label_map this s with
960: | `Local _ ->
961: " if(" ^ ge sr e ^ ")goto " ^ s ^ ";\n"
962: | `Nonlocal (pc,frame) ->
963: let skip = "_" ^ si !(syms.counter) in
964: incr syms.counter;
965: let not_e = ce_prefix "!" (ge' sr e) in
966: let not_e = string_of_cexpr not_e in
967: " if("^not_e^")goto " ^ skip ^ ";\n" ^
968: gen_nonlocal_goto pc frame s ^
969: " " ^ skip ^ ":;\n"
970:
971: | `Unreachable ->
972: clierr sr ("Jump to unreachable label " ^ s)
973: end
974:
975: | `BEXE_ifnotgoto (sr,e,s) ->
976: begin match find_label bbdfns label_map this s with
977: | `Local _ ->
978: (*
979: let not_e = ce_prefix "!" (ge' sr e) in
980: let not_e = string_of_cexpr not_e in
981: " if("^not_e^")goto " ^ s ^ ";\n"
982: *)
983: " ifnot(" ^ ge sr e ^ ")goto " ^ s ^ ";\n"
984:
985: | `Nonlocal (pc,frame) ->
986: let skip = "_" ^ si !(syms.counter) in
987: incr syms.counter;
988: " if(" ^ ge sr e ^ ")goto " ^ skip ^ ";\n" ^
989: gen_nonlocal_goto pc frame s ^
990: " " ^ skip ^ ":;\n"
991:
992: | `Unreachable ->
993: clierr sr ("Jump to unreachable label " ^ s)
994: end
995:
996: (* Hmmm .. stack calls ?? *)
997: | `BEXE_call_stack (sr,index,ts,a) ->
998: let id,parent,sr2,entry =
999: try Hashtbl.find bbdfns index
1000: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
1001: in
1002: let ge_arg ((x,t) as a) =
1003: let t = tsub t in
1004: match t with
1005: | `BTYP_tuple [] -> ""
1006: | _ -> ge sr a
1007: in
1008: let nth_type ts i = match ts with
1009: | `BTYP_tuple ts -> nth ts i
1010: | `BTYP_array (t,`BTYP_unitsum n) -> assert (i<n); t
1011: | _ -> assert false
1012: in
1013: begin match entry with
1014: | `BBDCL_procedure (props,vs,(ps,traint),_) ->
1015: let a = match a with (a,t) -> a, tsub t in
1016: let ts = map tsub ts in
1017: (* C FUNCTION CALL *)
1018: if mem `Pure props && not (mem `Heap_closure props) then
1019: let display = get_display_list bbdfns index in
1020: let name = cpp_instance_name syms bbdfns index ts in
1021: let s =
1022: assert (length display = 0);
1023: match ps with
1024: | [] -> ""
1025: | [_,(i,t)] ->
1026: if Hashtbl.mem syms.instances (i,ts)
1027: && not (t = `BTYP_tuple[])
1028: then
1029: ge_arg a
1030: else ""
1031:
1032: | _ ->
1033: begin match a with
1034: | `BEXPR_tuple xs,_ ->
1035: (*
1036: print_endline ("Arg to C function is tuple " ^ sbe syms.dfns a);
1037: *)
1038: fold_left
1039: (fun s (((x,t) as xt),(_,(i,_))) ->
1040: let x =
1041: if Hashtbl.mem syms.instances (i,ts)
1042: && not (t = `BTYP_tuple[])
1043: then ge_arg xt
1044: else ""
1045: in
1046: if String.length x = 0 then s else
1047: s ^
1048: (if String.length s > 0 then ", " else "") ^ (* append a comma if needed *)
1049: x
1050: )
1051: ""
1052: (combine xs ps)
1053:
1054: | _,tt ->
1055: let tt = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts tt))) in
1056: (* NASTY, EVALUATES EXPR MANY TIMES .. *)
1057: let n = ref 0 in
1058: fold_left
1059: (fun s (i,(_,(j,t))) ->
1060: (*
1061: print_endline ( "ps = " ^ catmap "," (fun (id,(p,t)) -> id) ps);
1062: print_endline ("tt=" ^ sbt syms.dfns tt);
1063: *)
1064: let t = nth_type tt i in
1065: let a' = `BEXPR_get_n (i,a),t in
1066: let x =
1067: if Hashtbl.mem syms.instances (j,ts)
1068: && not (t = `BTYP_tuple[])
1069: then ge_arg a'
1070: else ""
1071: in
1072: incr n;
1073: if String.length x = 0 then s else
1074: s ^ (if String.length s > 0 then ", " else "") ^ x
1075: )
1076: ""
1077: (combine (nlist (length ps)) ps)
1078: end
1079: in
1080: let s =
1081: if mem `Requires_ptf props then
1082: if String.length s > 0 then "FLX_FPAR_PASS " ^ s
1083: else "FLX_FPAR_PASS_ONLY"
1084: else s
1085: in
1086: " " ^ name ^ "(" ^ s ^ ");\n"
1087: else
1088: let subs,x = unravel syms bbdfns a in
1089: let subs = map (fun ((e,t),s) -> (e,tsub t),s) subs in
1090: handle_closure sr false index ts subs x true
1091: | _ -> failwith "procedure expected"
1092: end
1093:
1094:
1095: | `BEXE_call_prim (sr,index,ts,a)
1096: | `BEXE_call_direct (sr,index,ts,a)
1097: | `BEXE_call (sr,(`BEXPR_closure (index,ts),_),a) ->
1098: let a = match a with (a,t) -> a, tsub t in
1099: let subs,x = unravel syms bbdfns a in
1100: let subs = map (fun ((e,t),s) -> (e,tsub t),s) subs in
1101: let ts = map tsub ts in
1102: handle_closure sr false index ts subs x false
1103:
1104: | `BEXE_call_method_stack (sr,obj,meth,ts,a) ->
1105: let obj = match obj with (a,t) -> a, tsub t in
1106: let a = match a with (a,t) -> a, tsub t in
1107: let ts = map tsub ts in
1108: let the_display =
1109: let d' =
1110: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
1111: (get_display_list bbdfns meth)
1112: in
1113: let d' = tl d' in (* throw out class pointer *)
1114: if length d' > our_level
1115: then "this" :: tl d'
1116: else d'
1117: in
1118: let args = match a with
1119: | _,`BTYP_tuple [] -> ""
1120: | _ -> ge sr a
1121: in
1122: let class_frame = ge sr obj in
1123: let the_display = class_frame :: the_display in
1124: let meth_name = cpp_instance_name syms bbdfns meth ts in
1125: let meth_props =
1126: try match Hashtbl.find bbdfns meth with
1127: | _,_,_,`BBDCL_procedure (props,_,_,_)->props
1128: | _ -> failwith "Panic, index isn't procedure"
1129: with Not_found -> failwith "Panic, can't find procedure"
1130: in
1131: let labno = !counter in incr counter;
1132: let code =
1133: " " ^ meth_name ^ strd (the_display) meth_props ^
1134: "\n .stack_call(" ^ args ^ ");\n"
1135: in
1136: code
1137:
1138: | `BEXE_call_method_direct (sr,obj,meth,ts,a) ->
1139: let obj = match obj with (a,t) -> a, tsub t in
1140: let a = match a with (a,t) -> a, tsub t in
1141: let ts = map tsub ts in
1142: let the_display =
1143: let d' =
1144: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
1145: (get_display_list bbdfns meth)
1146: in
1147: let d' = tl d' in (* throw out class pointer *)
1148: if length d' > our_level
1149: then "this" :: tl d'
1150: else d'
1151: in
1152: let args = match a with
1153: | _,`BTYP_tuple [] -> "this"
1154: | _ -> "this" ^ ", " ^ ge sr a
1155: in
1156: let class_frame = ge sr obj in
1157: let the_display = class_frame :: the_display in
1158: let meth_name = cpp_instance_name syms bbdfns meth ts in
1159: let meth_props =
1160: try match Hashtbl.find bbdfns meth with
1161: | _,_,_,`BBDCL_procedure (props,_,_,_)->props
1162: | _ -> failwith "Panic, index isn't procedure"
1163: with Not_found -> failwith "Panic, can't find procedure"
1164: in
1165: let labno = !counter in incr counter;
1166: let code =
1167: " FLX_SET_PC(" ^ si labno ^ ")\n" ^
1168: " return (FLX_NEWP(" ^ meth_name ^ ")"^strd (the_display) meth_props ^ ")" ^
1169: "\n ->call(" ^ args ^ ");\n" ^
1170: " FLX_CASE_LABEL(" ^ si labno ^ ")\n"
1171: in
1172: needs_switch := true;
1173: code
1174:
1175: | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,a) ->
1176: let a = match a with (a,t) -> a, tsub t in
1177: let ts = map tsub ts in
1178: let the_display =
1179: let d' =
1180: map (fun (i,vslen) -> "ptr"^cpp_instance_name syms bbdfns i (list_prefix ts vslen))
1181: (get_display_list bbdfns i2)
1182: in
1183: if length d' > our_level
1184: then "this" :: tl d'
1185: else d'
1186: in
1187: (* let var_name = cpp_instance_name syms bbdfns i1 ts in *)
1188: (* dummy type in variable name .. : *)
1189: let var_name = ge sr (`BEXPR_name (i1, []),`BTYP_void) in
1190: let class_name = cpp_instance_name syms bbdfns i2 ts in
1191: let class_props =
1192: try match Hashtbl.find bbdfns i2 with
1193: | _,_,_,`BBDCL_class (props,_)->props
1194: | _ -> failwith "Panic, index isn't class"
1195: with Not_found -> failwith "Panic, can't find class"
1196: in
1197: let ctor_props =
1198: try match Hashtbl.find bbdfns i3 with
1199: | _,_,_,`BBDCL_procedure (props,_,_,_)->props
1200: | _ -> failwith "Panic, index isn't procedure"
1201: with Not_found -> failwith "Panic, can't find procedure"
1202: in
1203: let args = match a with
1204: | _,`BTYP_tuple [] -> ""
1205: | _ -> ge sr a
1206: in
1207: let ctor_name = cpp_instance_name syms bbdfns i3 ts in
1208: let labno = !counter in incr counter;
1209: let code =
1210: " " ^ var_name ^ " = " ^
1211: " (FLX_NEWP(" ^ class_name ^ ")" ^ strd the_display class_props ^ ");\n" ^
1212: " " ^ ctor_name ^ strd (var_name::the_display) ctor_props ^
1213: "\n .stack_call(" ^ args ^ ");\n"
1214: in
1215: code
1216:
1217: | `BEXE_apply_ctor (sr,i1,i2,ts,i3,a) ->
1218: let a = match a with (a,t) -> a, tsub t in
1219: let ts = map tsub ts in
1220: let the_display =
1221: let d' =
1222: map (fun (i,vslen) -> "ptr"^cpp_instance_name syms bbdfns i (list_prefix ts vslen))
1223: (get_display_list bbdfns i2)
1224: in
1225: if length d' > our_level
1226: then "this" :: tl d'
1227: else d'
1228: in
1229: (* let var_name = cpp_instance_name syms bbdfns i1 ts in *)
1230: (* dummy type in variable name .. : *)
1231: let var_name = ge sr (`BEXPR_name (i1, []),`BTYP_void) in
1232: let class_name = cpp_instance_name syms bbdfns i2 ts in
1233: let class_props =
1234: try match Hashtbl.find bbdfns i2 with
1235: | _,_,_,`BBDCL_class (props,_)->props
1236: | _ -> failwith "Panic, index isn't class"
1237: with Not_found -> failwith "Panic, can't find class"
1238: in
1239: let ctor_props =
1240: try match Hashtbl.find bbdfns i3 with
1241: | _,_,_,`BBDCL_procedure (props,_,_,_)->props
1242: | _ -> failwith "Panic, index isn't procedure"
1243: with Not_found -> failwith "Panic, can't find procedure"
1244: in
1245: let args = match a with
1246: | _,`BTYP_tuple [] -> "this"
1247: | _ -> let a = ge sr a in "this" ^ ", " ^ a
1248: in
1249: let ctor_name = cpp_instance_name syms bbdfns i3 ts in
1250: let labno = !counter in incr counter;
1251: let code =
1252: needs_switch := true;
1253: " " ^ var_name ^ " = " ^
1254: " (FLX_NEWP(" ^ class_name ^ ")" ^ strd the_display class_props ^ ");\n" ^
1255: " FLX_SET_PC(" ^ si labno ^ ")\n" ^
1256: " return (FLX_NEWP(" ^ ctor_name ^ ")"^strd (var_name::the_display) ctor_props ^ ")" ^
1257: "\n ->call(" ^ args ^ ");\n" ^
1258: " FLX_CASE_LABEL(" ^ si labno ^ ")\n"
1259: in
1260: code
1261:
1262: | `BEXE_jump (sr,((`BEXPR_closure (index,ts),_)),a)
1263: | `BEXE_jump_direct (sr,index,ts,a) ->
1264: let a = match a with (a,t) -> a, tsub t in
1265: let subs,x = unravel syms bbdfns a in
1266: let subs = map (fun ((e,t),s) -> (e,tsub t),s) subs in
1267: let ts = map tsub ts in
1268: handle_closure sr true index ts subs x false
1269:
1270: | `BEXE_loop (sr,i,a) ->
1271: let ptr =
1272: if i= this then "this"
1273: else "ptr"^cpp_instance_name syms bbdfns i ts
1274: in
1275: print_endline ("Looping to " ^ ptr);
1276: let args = ptr ^ "->" ^
1277: (match a with
1278: | _,`BTYP_tuple [] -> "_caller"
1279: | _ -> "_caller, " ^ ge sr a
1280: )
1281: in
1282: " //"^ src_str ^ "\n" ^
1283: (
1284: if i <> this then
1285: " {\n" ^
1286: " con_t *res = " ^ ptr ^ "\n ->call(" ^ args ^");\n" ^
1287: " printf(\"unwinding from %p to %p\\n\",this,"^ptr^");\n" ^
1288: " con_t *p = this;\n" ^
1289: " while(res && res != "^ptr^") { res = p->_caller; printf(\"called by %p\\n\",p); }\n"^
1290: " for(con_t *tmp=this; tmp != (con_t*)"^ptr^";){//unwind stack\n" ^
1291: " con_t *tmp2 = tmp->_caller;\n" ^
1292: " printf(\"unwinding %p, caller is %p\\n\",tmp,tmp2);\n" ^
1293: " tmp->_caller = 0;\n" ^
1294: " tmp = tmp2;\n"^
1295: " }\n" ^
1296: " return res;\n" ^
1297: " }\n"
1298: else
1299: " return " ^ ptr ^ "\n ->call(" ^ args ^");\n"
1300: )
1301:
1302: (* If p is a variable containing a closure,
1303: and p recursively invokes the same closure,
1304: then the program counter and other state
1305: of the closure would be lost, so we clone it
1306: instead .. the closure variables is never
1307: used (a waste if it isn't re-entered .. oh well)
1308: *)
1309:
1310: | `BEXE_call (sr,p,a) ->
1311: let args =
1312: let this = match kind with
1313: | Procedure -> "this"
1314: | Function -> "0"
1315: in
1316: match a with
1317: | _,`BTYP_tuple [] -> this
1318: | _ -> this ^ ", " ^ ge sr a
1319: in
1320: begin match kind with
1321: | Function ->
1322: (if with_comments then
1323: " //run procedure " ^ src_str ^ "\n"
1324: else "") ^
1325: " {\n" ^
1326: " con_t *_p = "^ge sr p ^ "->clone()\n ->call("^args^");\n" ^
1327: " while(_p) _p=_p->resume();\n" ^
1328: " }\n"
1329:
1330:
1331:
1332: | Procedure ->
1333: needs_switch := true;
1334: let n = !counter in
1335: incr counter;
1336: (if with_comments then
1337: " //"^ src_str ^ "\n"
1338: else "") ^
1339: " FLX_SET_PC(" ^ si n ^ ")\n" ^
1340: " return " ^ ge sr p ^ "->clone()\n ->call(" ^ args ^");\n" ^
1341: " FLX_CASE_LABEL(" ^ si n ^ ")\n"
1342: end
1343:
1344: | `BEXE_jump (sr,p,a) ->
1345: let args = match a with
1346: | _,`BTYP_tuple [] -> "tmp"
1347: | _ -> "tmp, " ^ ge sr a
1348: in
1349: (if with_comments then
1350: " //"^ src_str ^ "\n"
1351: else "") ^
1352: " {\n" ^
1353: " con_t *tmp = _caller;\n" ^
1354: " _caller=0;\n" ^
1355: " return " ^ ge sr p ^ "\n ->call(" ^ args ^");\n" ^
1356: " }\n"
1357:
1358: | `BEXE_proc_return _ ->
1359: if stackable then
1360: " return;\n"
1361: else
1362: " FLX_RETURN\n"
1363:
1364: | `BEXE_svc (sr,index) ->
1365: let id,parent,sr,entry =
1366: try Hashtbl.find bbdfns index
1367: with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
1368: in
1369: let t =
1370: match entry with
1371: | `BBDCL_var (_,t) -> t
1372: | `BBDCL_val (_,t) -> t
1373: | _ -> syserr sr "Expected read argument to be variable"
1374: in
1375: let n = !counter in incr counter;
1376: needs_switch := true;
1377: " //read variable\n" ^
1378: " p_svc = &" ^ get_var_ref syms bbdfns this index ts^";\n" ^
1379: " FLX_SET_PC(" ^ si n ^ ")\n" ^
1380: " return this;\n" ^
1381: " FLX_CASE_LABEL(" ^ si n ^ ")\n"
1382:
1383:
1384: | `BEXE_fun_return (sr,e) ->
1385: let _,t = e in
1386: (if with_comments then
1387: " //" ^ src_str ^ ": type "^tn t^"\n"
1388: else "") ^
1389: " return "^ge sr e^";\n"
1390:
1391: | `BEXE_nop (_,s) -> " //Nop: " ^ s ^ "\n"
1392:
1393: | `BEXE_assign (sr,e1,(( _,t) as e2)) ->
1394: let t = lstrip syms.dfns (tsub t) in
1395: begin match t with
1396: | `BTYP_tuple [] -> ""
1397: | _ ->
1398: (if with_comments then " //"^src_str^"\n" else "") ^
1399: " "^ ge sr e1 ^ " = " ^ ge sr e2 ^
1400: ";\n"
1401: end
1402:
1403: | `BEXE_init (sr,v,((_,t) as e)) ->
1404: let t = lstrip syms.dfns (tsub t) in
1405: begin match t with
1406: | `BTYP_tuple [] -> ""
1407: | _ ->
1408: let id,_,_,entry =
1409: try Hashtbl.find bbdfns v with
1410: Not_found -> failwith ("[gen_expr(init) can't find index " ^ si v)
1411: in
1412: begin match entry with
1413: | `BBDCL_tmp _ ->
1414: (if with_comments then " //"^src_str^"\n" else "") ^
1415: " "^
1416: get_variable_typename syms bbdfns v [] ^
1417: " " ^
1418: get_var_ref syms bbdfns this v ts^
1419: " = " ^
1420: ge sr e ^
1421: ";\n"
1422: | `BBDCL_val _
1423: | `BBDCL_var _ ->
1424: (*
1425: print_endline ("INIT of " ^ si v ^ " inside " ^ si this);
1426: *)
1427: (if with_comments then " //"^src_str^"\n" else "") ^
1428: " "^
1429: get_var_ref syms bbdfns this v ts^
1430: " = " ^
1431: ge sr e ^
1432: ";\n"
1433: | _ -> assert false
1434: end
1435: end
1436:
1437: | `BEXE_begin -> " {\n"
1438: | `BEXE_end -> " }\n"
1439:
1440: | `BEXE_assert (sr,e) ->
1441: let f,sl,sc,el,ec = sr in
1442: let s = string_of_string f ^"," ^
1443: si sl ^ "," ^ si sc ^ "," ^
1444: si el ^ "," ^ si ec
1445: in
1446: " {if(!(" ^ ge sr e ^ "))FLX_ASSERT_FAILURE("^s^");}\n"
1447:
1448: | `BEXE_assert2 (sr,sr2,e) ->
1449: let f,sl,sc,el,ec = sr in
1450: let s = string_of_string f ^"," ^
1451: si sl ^ "," ^ si sc ^ "," ^
1452: si el ^ "," ^ si ec
1453: in
1454: let f2,sl2,sc2,el2,ec2 = sr2 in
1455: let s2 = string_of_string f2 ^"," ^
1456: si sl2 ^ "," ^ si sc2 ^ "," ^
1457: si el2 ^ "," ^ si ec2
1458: in
1459: " {if(!(" ^ ge sr e ^ "))FLX_ASSERT2_FAILURE("^s^"," ^ s2 ^");}\n"
1460: in gexe exe
1461:
1462: let gen_exes filename syms bbdfns display label_info counter index exes vs ts instance_no stackable =
1463: let needs_switch = ref false in
1464: let s = cat ""
1465: (map (gen_exe filename syms bbdfns label_info counter index vs ts instance_no needs_switch stackable) exes)
1466: in
1467: s,!needs_switch
1468:
1469: (* PROCEDURES are implemented by continuations.
1470: The constructor accepts the display vector to
1471: form the closure object. The call method accepts
1472: the callers continuation object as a return address,
1473: and the procedure argument, and returns a continuation.
1474: The resume method runs the continuation until
1475: it returns a continuation to some object, possibly
1476: the same object. A flag in the continuation object
1477: determines whether the yield of control is a request
1478: for data or not (if so, the dispatcher must place the data
1479: in the nominated place before calling the resume method again.
1480: *)
1481:
1482: (* FUNCTIONS are implemented as functoids:
1483: the constructor accepts the display vector so as
1484: to form a closure object, the apply method
1485: accepts the argument and runs the function.
1486: The machine stack is used for functions.
1487: *)
1488: let gen_C_function_body filename syms (child_map,bbdfns)
1489: label_info counter index ts instance_no
1490: =
1491: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
1492: let id,parent,sr,entry =
1493: try Hashtbl.find bbdfns index
1494: with Not_found -> failwith ("gen_C_function_body] can't find " ^ si index)
1495: in
1496: if syms.compiler_options.print_flag then
1497: print_endline
1498: (
1499: "//Generating C function body inst " ^
1500: si instance_no ^ "=" ^
1501: id ^ "<" ^si index^">" ^
1502: (
1503: if length ts = 0 then ""
1504: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
1505: )
1506: );
1507: match entry with
1508: | `BBDCL_function (props,vs,(bps,traint),ret',exes) ->
1509: let requires_ptf = mem `Requires_ptf props in
1510: if length ts <> length vs then
1511: failwith
1512: (
1513: "[get_function_methods] wrong number of type args, expected vs = " ^
1514: si (length vs) ^
1515: ", got ts=" ^
1516: si (length ts)
1517: );
1518: let name = cpp_instance_name syms bbdfns index ts in
1519:
1520: "//C FUNC " ^ name ^ "\n" ^
1521:
1522: let argtype = lower (typeof_bparams bps) in
1523: let argtype = rt vs argtype in
1524: let rt' vs t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
1525: let ret = rt' vs ret' in
1526: let is_ref = match ret with | `BTYP_lvalue _ -> true | _ -> false in
1527: let ret = lstrip syms.dfns ret in
1528: if ret = `BTYP_tuple [] then "// elided (returns unit)\n\n" else
1529:
1530:
1531: let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
1532: let argtypename = cpp_typename syms argtype in
1533: let rettypename = cpp_typename syms ret in
1534:
1535: let params = map (fun (id,(ix,t)) -> ix) bps in
1536: let exe_string,_ =
1537: try
1538: gen_exes filename syms (child_map,bbdfns) [] label_info counter index exes vs ts instance_no true
1539: with x ->
1540: print_endline (Printexc.to_string x);
1541: print_endline (catmap "\n" (string_of_bexe syms.dfns 1) exes);
1542: print_endline "Can't gen exes ..";
1543: raise x
1544: in
1545: let dcl_vars =
1546: let kids = find_children child_map index in
1547: let kids =
1548: fold_left
1549: (fun lst i ->
1550: let _,_,_,entry =
1551: try Hashtbl.find bbdfns i
1552: with Not_found -> failwith ("[C func body, vars] Can't find index " ^ si i);
1553: in
1554: match entry with
1555: | `BBDCL_var (vs,t)
1556: | `BBDCL_val (vs,t)
1557: when not (mem i params) ->
1558: (i, rt vs t) :: lst
1559: | _ -> lst
1560: )
1561: [] kids
1562: in
1563: fold_left
1564: (fun s (i,t) -> s ^ " " ^
1565: cpp_typename syms t ^ " " ^
1566: cpp_instance_name syms bbdfns i ts ^ ";\n"
1567: )
1568: "" kids
1569: in
1570: rettypename ^ " " ^
1571: (if is_ref then "& " else "") ^
1572: "FLX_REGPARM " ^
1573: name ^ "(" ^
1574: (
1575: let s =
1576: match length params with
1577: | 0 -> ""
1578: | 1 ->
1579: let ix = hd params in
1580: if Hashtbl.mem syms.instances (ix, ts)
1581: && not (argtype = `BTYP_tuple [])
1582: then
1583: argtypename ^ " " ^ cpp_instance_name syms bbdfns ix ts
1584: else ""
1585: | _ ->
1586: let counter = ref 0 in
1587: fold_left
1588: (fun s (_,(i,t)) ->
1589: let t = rt vs (lower t) in
1590: let n = !counter in incr counter;
1591: if Hashtbl.mem syms.instances (i,ts) && not (t = `BTYP_tuple [])
1592: then s ^
1593: (if String.length s > 0 then ", " else " ") ^
1594: cpp_typename syms t ^ " " ^
1595: cpp_instance_name syms bbdfns i ts
1596: else s (* elide initialisation of elided variable *)
1597: )
1598: ""
1599: bps
1600: in
1601: (
1602: if requires_ptf then
1603: if String.length s > 0
1604: then "FLX_APAR_DECL " ^ s
1605: else "FLX_APAR_DECL_ONLY"
1606: else s
1607: )
1608: )^
1609: "){\n" ^
1610: (*
1611: (if mem `Uses_gc props then
1612: " collector_t &gc = *PTF gc;\n"
1613: else ""
1614: ) ^
1615: *)
1616: (* NO LONGER UNPACK ARGUMENT
1617: (
1618: match length params with
1619: | 0 -> ""
1620: | 1 ->
1621: let i = hd params in
1622: if Hashtbl.mem syms.instances (i, ts)
1623: && not (argtype = `BTYP_tuple [])
1624: then
1625: argtypename ^ " " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg;\n"
1626: else ""
1627: | _ ->
1628: let counter = ref 0 in fold_left
1629: (fun s i ->
1630: let n = !counter in incr counter;
1631: if Hashtbl.mem syms.instances (i,ts)
1632: then
1633: let memexpr,t =
1634: match argtype with
1635: | `BTYP_array (t,`BTYP_unitsum _) -> ".data["^si n^"]",t
1636: | `BTYP_tuple ts -> ".mem_"^ si n,
1637: begin try nth ts n
1638: with Not_found ->
1639: failwith ("Can't find component " ^ si n ^ " of " ^ sbt syms.dfns argtype)
1640: end
1641:
1642: | _ -> assert false
1643: in
1644: let t = cpp_typename syms t in
1645: s ^ " " ^ t ^ " " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg"^ memexpr ^";\n"
1646: else s (* elide initialisation of elided variable *)
1647: )
1648: "" params
1649: )^
1650: *)
1651: dcl_vars ^
1652: exe_string ^
1653: "}\n"
1654:
1655: | _ -> failwith "function expected"
1656:
1657: let gen_C_procedure_body filename syms (child_map,bbdfns)
1658: label_info counter index ts instance_no
1659: =
1660: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
1661: let id,parent,sr,entry =
1662: try Hashtbl.find bbdfns index
1663: with Not_found -> failwith ("gen_C_function_body] can't find " ^ si index)
1664: in
1665: if syms.compiler_options.print_flag then
1666: print_endline
1667: (
1668: "//Generating C procedure body inst " ^
1669: si instance_no ^ "=" ^
1670: id ^ "<" ^si index^">" ^
1671: (
1672: if length ts = 0 then ""
1673: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
1674: )
1675: );
1676: match entry with
1677: | `BBDCL_procedure (props,vs,(bps,traint),exes) ->
1678: let requires_ptf = mem `Requires_ptf props in
1679: if length ts <> length vs then
1680: failwith
1681: (
1682: "[get_function_methods] wrong number of type args, expected vs = " ^
1683: si (length vs) ^
1684: ", got ts=" ^
1685: si (length ts)
1686: );
1687: let name = cpp_instance_name syms bbdfns index ts in
1688:
1689: "//C PROC " ^ name ^ "\n" ^
1690:
1691: let argtype = lower (typeof_bparams bps) in
1692: let argtype = rt vs argtype in
1693:
1694: let funtype = fold syms.dfns (`BTYP_function (argtype, `BTYP_void)) in
1695: let argtypename = cpp_typename syms argtype in
1696:
1697: let params = map (fun (id,(ix,t)) -> ix) bps in
1698: let exe_string,_ =
1699: try
1700: gen_exes filename syms (child_map,bbdfns) [] label_info counter index exes vs ts instance_no true
1701: with x ->
1702: print_endline (Printexc.to_string x);
1703: print_endline (catmap "\n" (string_of_bexe syms.dfns 1) exes);
1704: print_endline "Can't gen exes ..";
1705: raise x
1706: in
1707: let dcl_vars =
1708: let kids = find_children child_map index in
1709: let kids =
1710: fold_left
1711: (fun lst i ->
1712: let _,_,_,entry =
1713: try Hashtbl.find bbdfns i
1714: with Not_found -> failwith ("[C func body, vars] Can't find index " ^ si i);
1715: in
1716: match entry with
1717: | `BBDCL_var (vs,t)
1718: | `BBDCL_val (vs,t)
1719: when not (mem i params) ->
1720: (i, rt vs t) :: lst
1721: | _ -> lst
1722: )
1723: [] kids
1724: in
1725: fold_left
1726: (fun s (i,t) -> s ^ " " ^
1727: cpp_typename syms t ^ " " ^
1728: cpp_instance_name syms bbdfns i ts ^ ";\n"
1729: )
1730: "" kids
1731: in
1732: "void " ^
1733: "FLX_REGPARM " ^
1734: name ^ "(" ^
1735: (
1736: let s =
1737: match length params with
1738: | 0 -> ""
1739: | 1 ->
1740: let ix = hd params in
1741: if Hashtbl.mem syms.instances (ix, ts)
1742: && not (argtype = `BTYP_tuple [])
1743: then
1744: argtypename ^ " " ^ cpp_instance_name syms bbdfns ix ts
1745: else ""
1746: | _ ->
1747: let counter = ref 0 in
1748: fold_left
1749: (fun s (_,(i,t)) ->
1750: let t = rt vs (lower t) in
1751: let n = !counter in incr counter;
1752: if Hashtbl.mem syms.instances (i,ts) && not (t = `BTYP_tuple [])
1753: then s ^
1754: (if String.length s > 0 then ", " else " ") ^
1755: cpp_typename syms t ^ " " ^
1756: cpp_instance_name syms bbdfns i ts
1757: else s (* elide initialisation of elided variable *)
1758: )
1759: ""
1760: bps
1761: in
1762: (
1763: if requires_ptf then
1764: if String.length s > 0
1765: then "FLX_APAR_DECL " ^ s
1766: else "FLX_APAR_DECL_ONLY"
1767: else s
1768: )
1769: )^
1770: "){\n" ^
1771: (*
1772: (if mem `Uses_gc props then
1773: " collector_t &gc = *PTF gc;\n"
1774: else ""
1775: ) ^
1776: *)
1777: (* NO LONGER UNPACK ARGUMENT
1778: (
1779: match length params with
1780: | 0 -> ""
1781: | 1 ->
1782: let i = hd params in
1783: if Hashtbl.mem syms.instances (i, ts)
1784: && not (argtype = `BTYP_tuple [])
1785: then
1786: argtypename ^ " " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg;\n"
1787: else ""
1788: | _ ->
1789: let counter = ref 0 in fold_left
1790: (fun s i ->
1791: let n = !counter in incr counter;
1792: if Hashtbl.mem syms.instances (i,ts)
1793: then
1794: let memexpr,t =
1795: match argtype with
1796: | `BTYP_array (t,`BTYP_unitsum _) -> ".data["^si n^"]",t
1797: | `BTYP_tuple ts -> ".mem_"^ si n,nth ts n
1798: | _ -> assert false
1799: in
1800: let t = cpp_typename syms t in
1801: s ^ " " ^ t ^ " " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg"^ memexpr ^";\n"
1802: else s (* elide initialisation of elided variable *)
1803: )
1804: "" params
1805: )^
1806: *)
1807: dcl_vars ^
1808: exe_string ^
1809: "}\n"
1810:
1811: | _ -> failwith "procedure expected"
1812:
1813: let gen_function_methods filename syms (child_map,bbdfns)
1814: label_info counter index ts instance_no
1815: =
1816: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
1817: let id,parent,sr,entry =
1818: try Hashtbl.find bbdfns index
1819: with Not_found -> failwith ("[gen_function_methods] can't find " ^ si index)
1820: in
1821: if syms.compiler_options.print_flag then
1822: print_endline
1823: (
1824: "//Generating function body inst " ^
1825: si instance_no ^ "=" ^
1826: id ^ "<" ^si index^">" ^
1827: (
1828: if length ts = 0 then ""
1829: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
1830: )
1831: );
1832: match entry with
1833: | `BBDCL_function (props,vs,(bps,traint),ret',exes) ->
1834: if length ts <> length vs then
1835: failwith
1836: (
1837: "[get_function_methods} wrong number of args, expected vs = " ^
1838: si (length vs) ^
1839: ", got ts=" ^
1840: si (length ts)
1841: );
1842: let argtype = lower (typeof_bparams bps) in
1843: let argtype = rt vs argtype in
1844: let rt' vs t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
1845: let ret = rt' vs ret' in
1846: let is_ref = match ret with | `BTYP_lvalue _ -> true | _ -> false in
1847: let ret = lstrip syms.dfns ret in
1848: if ret = `BTYP_tuple [] then "// elided (returns unit)\n" else
1849:
1850: let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
1851:
1852: let argtypename = cpp_typename syms argtype in
1853: let name = cpp_instance_name syms bbdfns index ts in
1854:
1855: let display = get_display_list bbdfns index in
1856:
1857: let rettypename = cpp_typename syms ret in
1858:
1859: let ctor =
1860: let vars = find_references syms (child_map,bbdfns) index ts in
1861: let funs = filter (fun (_,t) -> is_gc_pointer syms bbdfns sr t) vars in
1862: gen_ctor syms bbdfns name display funs [] [] ts props
1863: in
1864: let params = map (fun (id,(ix,t)) -> ix) bps in
1865: let exe_string,_ =
1866: try
1867: gen_exes filename syms (child_map,bbdfns) display label_info counter index exes vs ts instance_no false
1868: with x ->
1869: print_endline (Printexc.to_string x);
1870: print_endline (catmap "\n" (string_of_bexe syms.dfns 1) exes);
1871: print_endline "Can't gen exes ..";
1872: raise x
1873: in
1874: let cont = "con_t *" in
1875: let apply =
1876: rettypename^ " " ^name^
1877: "::apply("^
1878: (if argtype = `BTYP_tuple []
1879: then ""
1880: else argtypename ^" const &_arg ")^
1881: "){\n" ^
1882: (*
1883: (if mem `Uses_gc props then
1884: " collector_t &gc = *PTF gc;\n"
1885: else ""
1886: )
1887: ^
1888: *)
1889: (
1890: match length params with
1891: | 0 -> ""
1892: | 1 ->
1893: let i = hd params in
1894: if Hashtbl.mem syms.instances (i, ts)
1895: && not (argtype = `BTYP_tuple [])
1896: then
1897: " " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg;\n"
1898: else ""
1899: | _ ->
1900: let counter = ref 0 in fold_left
1901: (fun s i ->
1902: let n = !counter in incr counter;
1903: if Hashtbl.mem syms.instances (i,ts)
1904: then
1905: let memexpr =
1906: match argtype with
1907: | `BTYP_array _ -> ".data["^si n^"]"
1908: | `BTYP_tuple _ -> ".mem_"^ si n
1909: | _ -> assert false
1910: in
1911: s ^ " " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg"^ memexpr ^";\n"
1912: else s (* elide initialisation of elided variable *)
1913: )
1914: "" params
1915: )^
1916: exe_string ^
1917: "}\n"
1918: and clone =
1919: " " ^ name ^ "* "^name^"::clone()const {\n"^
1920: " return new(*PTF gc,"^name^"_ptr_map) "^name^"(*this);\n"^
1921: "}\n"
1922: in
1923: let q = qualified_name_of_index syms.dfns index in
1924: "//FUNC " ^ q ^ ": Constructor\n" ^
1925: ctor^ "\n" ^
1926: (
1927: if mem `Heap_closure props then
1928: "\n//FUNC " ^ q ^ ": Clone method\n" ^
1929: clone^ "\n"
1930: else ""
1931: )
1932: ^
1933: "//FUNC " ^ q ^ ": Apply method\n" ^
1934: apply^ "\n"
1935:
1936: | _ -> failwith "function expected"
1937:
1938: let gen_regexp_methods filename syms (child_map,bbdfns)
1939: label_info counter index ts instance_no
1940: =
1941: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
1942: let id,parent,sr,entry =
1943: try Hashtbl.find bbdfns index
1944: with Not_found -> failwith ("[gen_regexp_methods] Can't find index " ^ si index)
1945: in
1946: if syms.compiler_options.print_flag then
1947: print_endline
1948: (
1949: "//Generating regmatch/reglex body inst " ^
1950: si instance_no ^ "=" ^
1951: id ^ "<" ^si index^">" ^
1952: (
1953: if length ts = 0 then ""
1954: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
1955: )
1956: );
1957: let lexeme_start,buffer_end,lexeme_end,kind = match entry with
1958: | `BBDCL_regmatch (props,vs,(bps,traint),ret',cls) ->
1959: let p1 = fst (snd (hd bps)) in
1960: let p1' = cpp_instance_name syms bbdfns p1 ts in
1961: let p2 = fst (snd (hd (tl bps))) in
1962: let p2' = cpp_instance_name syms bbdfns p2 ts in
1963: p1',p2',None,`regmatch (p1',p2')
1964:
1965: | `BBDCL_reglex (props,vs,(bps,traint),i,ret',cls) ->
1966: let p1 = fst (snd (hd bps)) in
1967: let p1' = cpp_instance_name syms bbdfns p1 ts in
1968: let p2 = fst (snd (hd (tl bps))) in
1969: let p2' = cpp_instance_name syms bbdfns p2 ts in
1970: let v = cpp_instance_name syms bbdfns i ts in
1971: p1',p2',Some v,`reglex (p1',p2',v)
1972:
1973: | _ -> assert false
1974: in
1975: match entry with
1976: | `BBDCL_regmatch (props,vs,(bps,traint),ret',cls)
1977: | `BBDCL_reglex (props,vs,(bps,traint),_,ret',cls) ->
1978: if length ts <> length vs then
1979: failwith
1980: (
1981: "[get_function_methods} wrong number of args, expected vs = " ^
1982: si (length vs) ^
1983: ", got ts=" ^
1984: si (length ts)
1985: );
1986: let argtype = lower (typeof_bparams bps) in
1987: let argtype = rt vs argtype in
1988: let ret = rt vs (lower ret') in
1989: let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
1990:
1991: let argtypename = cpp_typename syms argtype in
1992: let name = cpp_instance_name syms bbdfns index ts in
1993:
1994: let display = get_display_list bbdfns index in
1995:
1996: let rettypename = cpp_typename syms ret in
1997:
1998: let ctor =
1999: let vars = find_references syms (child_map,bbdfns) index ts in
2000: let funs = filter (fun (_,t) -> is_gc_pointer syms bbdfns sr t) vars in
2001: gen_ctor syms bbdfns name display funs [] [] ts props
2002: in
2003: let params = map (fun (id,(ix,t)) -> ix) bps in
2004: let exe_string =
2005: let ge e : string = gen_expr syms bbdfns index e vs ts sr in
2006: let b = Buffer.create 2000 in
2007: Flx_regen.regen b sr cls kind ge;
2008: Buffer.contents b
2009: in
2010: let cont = "con_t *" in
2011: let apply =
2012: rettypename^ " " ^name^ "::apply("^
2013: argtypename ^" const &_arg ){\n" ^
2014: (*
2015: (if mem `Uses_gc props then
2016: " collector_t &gc = *PTF gc;\n"
2017: else ""
2018: ) ^
2019: *)
2020: " " ^ lexeme_start ^ " = _arg.data[0];\n" ^
2021: " " ^ buffer_end ^ " = _arg.data[1];\n" ^
2022: exe_string ^
2023: "}\n"
2024: and clone =
2025: " " ^ name ^ "* "^name^"::clone()const {\n"^
2026: " return new(*PTF gc,"^name^"_ptr_map) "^name^"(*this);\n"^
2027: "}\n"
2028: in
2029: let q = qualified_name_of_index syms.dfns index in
2030: "//FUNC " ^ q ^ ": Constructor\n" ^
2031: ctor^ "\n" ^
2032: (
2033: if mem `Heap_closure props then
2034: "\n//FUNC " ^ q ^ ": Clone method\n" ^
2035: clone^ "\n"
2036: else ""
2037: )
2038: ^
2039: "//FUNC " ^ q ^ ": Apply method\n" ^
2040: apply^ "\n"
2041:
2042: | _ -> failwith "function expected"
2043:
2044:
2045: let gen_class_methods filename syms (child_map,bbdfns)
2046: label_info counter index ts instance_no
2047: =
2048: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
2049: let id,parent,sr,entry =
2050: try Hashtbl.find bbdfns index
2051: with Not_found -> failwith ("[gen_class_methods] Can't find index " ^ si index)
2052: in (* can't fail *)
2053: if syms.compiler_options.print_flag then
2054: print_endline
2055: (
2056: "//Generating class inst " ^
2057: si instance_no ^ "=" ^
2058: id ^ "<" ^si index^">" ^
2059: (
2060: if length ts = 0 then ""
2061: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
2062: )
2063: );
2064: match entry with
2065: | `BBDCL_class (props,vs) ->
2066: if length ts <> length vs then
2067: failwith
2068: (
2069: "[get_class_methods} wrong number of args, expected vs = " ^
2070: si (length vs) ^
2071: ", got ts=" ^
2072: si (length ts)
2073: );
2074:
2075: let name = cpp_instance_name syms bbdfns index ts in
2076: let display = get_display_list bbdfns index in
2077: let ctor =
2078: let vars = find_references syms (child_map,bbdfns) index ts in
2079: let funs = filter (fun (_,t) -> is_gc_pointer syms bbdfns sr t) vars in
2080: gen_ctor syms bbdfns name display funs [] [] ts props
2081: in
2082:
2083: let q =
2084: try qualified_name_of_index syms.dfns index
2085: with Not_found ->
2086: si instance_no ^ "=" ^
2087: id ^ "<" ^si index^">" ^
2088: (
2089: if length ts = 0 then ""
2090: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
2091: )
2092: in
2093: "\n//CLASS " ^ q ^ "\n" ^
2094: "//CLASS " ^ q ^ ": Constructor\n" ^
2095: ctor
2096:
2097: | _ -> failwith "class expected"
2098:
2099: let gen_procedure_methods filename syms (child_map,bbdfns)
2100: label_info counter index ts instance_no
2101: =
2102: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
2103: let id,parent,sr,entry =
2104: try Hashtbl.find bbdfns index
2105: with Not_found -> failwith ("[gen_procedure_methods] Can't find index " ^ si index)
2106: in (* can't fail *)
2107: if syms.compiler_options.print_flag then
2108: print_endline
2109: (
2110: "//Generating procedure body inst " ^
2111: si instance_no ^ "=" ^
2112: id ^ "<" ^si index^">" ^
2113: (
2114: if length ts = 0 then ""
2115: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
2116: )
2117: );
2118: match entry with
2119: | `BBDCL_procedure (props,vs,(bps,traint),exes) ->
2120: if length ts <> length vs then
2121: failwith
2122: (
2123: "[get_procedure_methods} wrong number of args, expected vs = " ^
2124: si (length vs) ^
2125: ", got ts=" ^
2126: si (length ts)
2127: );
2128: let stackable = mem `Stack_closure props in
2129: let heapable = mem `Heap_closure props in
2130: let heapable = not stackable or heapable in
2131: let argtype = lower (typeof_bparams bps) in
2132: let argtype = rt vs argtype in
2133: let funtype = fold syms.dfns (`BTYP_function (argtype, `BTYP_void)) in
2134:
2135: let argtypename = cpp_typename syms argtype in
2136: let name = cpp_instance_name syms bbdfns index ts in
2137:
2138: let display = get_display_list bbdfns index in
2139:
2140: let ctor =
2141: let vars = find_references syms (child_map,bbdfns) index ts in
2142: let funs = filter (fun (i,t) -> is_gc_pointer syms bbdfns sr t) vars in
2143: gen_ctor syms bbdfns name display funs [] [] ts props
2144: in
2145:
2146: (*
2147: let dtor = gen_dtor syms bbdfns name display ts in
2148: *)
2149: let ps = map (fun (id,(ix,t)) -> id,t) bps in
2150: let params = map (fun (id,(ix,t)) -> ix) bps in
2151: let exe_string,needs_switch =
2152: gen_exes filename syms (child_map,bbdfns) display label_info counter index exes vs ts instance_no (stackable && not heapable)
2153: in
2154:
2155: let cont = "con_t *" in
2156: let heap_call_arg_sig, heap_call_arg =
2157: match argtype with
2158: | `BTYP_tuple [] -> cont ^ "_ptr_caller","0"
2159: | _ -> cont ^ "_ptr_caller, " ^ argtypename ^" const &_arg","0,_arg"
2160: and stack_call_arg_sig =
2161: match argtype with
2162: | `BTYP_tuple [] -> ""
2163: | _ -> argtypename ^" const &_arg"
2164: in
2165: let unpack_args =
2166: (match length bps with
2167: | 0 -> ""
2168: | 1 ->
2169: let _,(i,_) = hd bps in
2170: if Hashtbl.mem syms.instances (i,ts)
2171: && not (argtype = `BTYP_tuple[])
2172: then
2173: " " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg;\n"
2174: else ""
2175:
2176: | _ -> let counter = ref 0 in fold_left
2177: (fun s i ->
2178: let n = !counter in incr counter;
2179: if Hashtbl.mem syms.instances (i,ts)
2180: then
2181: let memexpr =
2182: match argtype with
2183: | `BTYP_array _ -> ".data["^si n^"]"
2184: | `BTYP_tuple _ -> ".mem_"^ si n
2185: | _ -> assert false
2186: in
2187: s ^ " " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg" ^ memexpr ^";\n"
2188: else s (* elide initialisation of elided variables *)
2189: )
2190: "" params
2191: )
2192: in
2193: let stack_call =
2194: "void " ^name^ "::stack_call(" ^ stack_call_arg_sig ^ "){\n" ^
2195: (
2196: if not heapable
2197: then unpack_args ^ exe_string
2198: else
2199: " con_t *cc = call("^heap_call_arg^");\n" ^
2200: " while(cc) cc = cc->resume();\n"
2201: ) ^ "\n}\n"
2202: and heap_call =
2203: cont ^ " " ^ name ^ "::call(" ^ heap_call_arg_sig ^ "){\n" ^
2204: " _caller = _ptr_caller;\n" ^
2205: unpack_args ^
2206: " INIT_PC\n" ^
2207: " return this;\n}\n"
2208: and resume =
2209: if exes = []
2210: then
2211: cont^name^"::resume(){//empty\n"^
2212: " FLX_RETURN\n" ^
2213: "}\n"
2214: else
2215: cont^name^"::resume(){\n"^
2216: (if needs_switch then
2217: " FLX_START_SWITCH\n" else ""
2218: ) ^
2219: exe_string ^
2220: " FLX_RETURN\n" ^ (* HACK .. should be in exe_string .. *)
2221: (if needs_switch then
2222: " FLX_END_SWITCH\n" else ""
2223: )^
2224: "}\n"
2225: and clone =
2226: " " ^name^"* "^name^"::clone()const {\n" ^
2227: " return new(*PTF gc,"^name^"_ptr_map) "^name^"(*this);\n" ^
2228: "}\n"
2229: in
2230: let q =
2231: try qualified_name_of_index syms.dfns index
2232: with Not_found ->
2233: si instance_no ^ "=" ^
2234: id ^ "<" ^si index^">" ^
2235: (
2236: if length ts = 0 then ""
2237: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
2238: )
2239: in
2240: "\n//PROC " ^ q ^ "\n" ^
2241: "//PROC " ^ q ^ ": Constructor\n" ^
2242: ctor^
2243: (
2244: if mem `Heap_closure props then
2245: "\n//PROC " ^ q ^ ": Clone method\n" ^
2246: clone
2247: else ""
2248: )
2249: ^
2250: "\n//PROC " ^ q ^ ": Call method\n" ^
2251: (if stackable then stack_call else "") ^
2252: (if heapable then heap_call else "") ^
2253: (if heapable then
2254: "\n//PROC " ^ q ^ ": Resume method\n" ^
2255: resume
2256: else ""
2257: )
2258:
2259: | _ -> failwith "procedure expected"
2260:
2261:
2262: let gen_execute_methods filename syms (child_map,bbdfns) label_info counter bf =
2263: let s = Buffer.create 2000 in
2264: Hashtbl.iter
2265: (fun (index,ts) instance_no ->
2266: let id,parent,sr,entry =
2267: try Hashtbl.find bbdfns index
2268: with Not_found -> failwith ("[gen_execute_methods] Can't find index " ^ si index)
2269: in
2270: begin match entry with
2271: | `BBDCL_function (props,vs,(ps,traint), ret, _) ->
2272: bcat s ("//------------------------------\n");
2273: if mem `Pure props && not (mem `Heap_closure props) then
2274: bcat s (
2275: gen_C_function_body filename syms (child_map,bbdfns)
2276: label_info counter index ts instance_no
2277: )
2278: else
2279: bcat s (
2280: gen_function_methods filename syms (child_map,bbdfns)
2281: label_info counter index ts instance_no
2282: )
2283:
2284: | `BBDCL_callback (props,vs,ps_cf,ps_c,client_data_pos,ret',_,_) ->
2285: let tss =
2286: if length ts = 0 then "" else
2287: "[" ^ catmap "," (string_of_btypecode syms.dfns) ts^ "]"
2288: in
2289: bcat s ("\n//------------------------------\n");
2290: if ret' = `BTYP_void then begin
2291: bcat s ("//CALLBACK C PROC " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
2292: end else begin
2293: bcat s ("//CALLBACK C FUNCTION " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
2294: end
2295: ;
2296: let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
2297: let ps_c = map (rt vs) ps_c in
2298: let ps_cf = map (rt vs) ps_cf in
2299: let ret = rt vs ret' in
2300: if syms.compiler_options.print_flag then
2301: print_endline
2302: (
2303: "//Generating C callback function inst " ^
2304: si instance_no ^ "=" ^
2305: id ^ "<" ^si index^">" ^
2306: (
2307: if length ts = 0 then ""
2308: else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
2309: )
2310: );
2311: if length ts <> length vs then
2312: failwith
2313: (
2314: "[gen_function} wrong number of args, expected vs = " ^
2315: si (length vs) ^
2316: ", got ts=" ^
2317: si (length ts)
2318: );
2319: (*
2320: let name = cpp_instance_name syms bbdfns index ts in
2321: *)
2322: let name = id in (* callbacks can't be polymorphic .. for now anyhow *)
2323: let rettypename = cpp_typename syms ret in
2324: let n = length ps_c in
2325: let flx_fun_atypes =
2326: rev
2327: (
2328: fold_left
2329: (fun lst (t,i) ->
2330: if i = client_data_pos
2331: then lst
2332: else (t,i)::lst
2333: )
2334: []
2335: (combine ps_c (nlist n))
2336: )
2337: in
2338: let flx_fun_atype =
2339: if length flx_fun_atypes = 1 then fst (hd flx_fun_atypes)
2340: else `BTYP_tuple (map fst flx_fun_atypes)
2341: in
2342: let flx_fun_reduced_atype = rt vs flx_fun_atype in
2343: let flx_fun_atype_name = cpp_typename syms flx_fun_atype in
2344: let flx_fun_reduced_atype_name = cpp_typename syms flx_fun_reduced_atype in
2345: let flx_fun_args = map (fun (_,i) -> "_a"^si i) flx_fun_atypes in
2346: let flx_fun_arg = match length flx_fun_args with
2347: | 0 -> ""
2348: | 1 -> hd flx_fun_args
2349: | _ ->
2350: (* argument tuple *)
2351: let a = flx_fun_atype_name ^ "(" ^ String.concat "," flx_fun_args ^")" in
2352: if flx_fun_reduced_atype_name <> flx_fun_atype_name
2353: then "reinterpret<" ^ flx_fun_reduced_atype_name ^ ">("^a^")"
2354: else a
2355:
2356: in
2357: let sss =
2358: (* return type *)
2359: rettypename ^ " " ^
2360:
2361: (* function name *)
2362: name ^ "(" ^
2363: (
2364: (* parameter list *)
2365: match length ps_c with
2366: | 0 -> ""
2367: | 1 -> cpp_typename syms (hd ps_c) ^ " _a0"
2368: | _ ->
2369: fold_left
2370: (fun s (t,j) ->
2371: s ^
2372: (if String.length s > 0 then ", " else "") ^
2373: cpp_typename syms t ^ " _a" ^ si j
2374: )
2375: ""
2376: (combine ps_c (nlist n))
2377: ) ^
2378: "){\n"^
2379: (
2380: (* body *)
2381: let flx_fun_type = nth ps_cf client_data_pos in
2382: let flx_fun_type_name = cpp_typename syms flx_fun_type in
2383: (* cast *)
2384: " " ^ flx_fun_type_name ^ " callback = ("^flx_fun_type_name^")_a" ^ si client_data_pos ^ ";\n" ^
2385: (
2386: if ret = `BTYP_void then begin
2387: " con_t *p = callback->call(0" ^
2388: (if String.length flx_fun_arg > 0 then "," ^ flx_fun_arg else "") ^
2389: ");\n" ^
2390: " while(p)p = p->resume();\n"
2391: end else begin
2392: " return callback->apply(" ^ flx_fun_arg ^ ");\n";
2393: end
2394: )
2395: )^
2396: " }\n"
2397: in bcat s sss
2398:
2399: | `BBDCL_procedure (props,vs,(ps,traint),_) ->
2400: bcat s ("//------------------------------\n");
2401: if mem `Pure props && not (mem `Heap_closure props) then
2402: bcat s (
2403: gen_C_procedure_body filename syms (child_map,bbdfns)
2404: label_info counter index ts instance_no
2405: )
2406: else
2407: bcat s (
2408: gen_procedure_methods filename syms (child_map,bbdfns)
2409: label_info counter index ts instance_no
2410: )
2411:
2412: | `BBDCL_regmatch _
2413: | `BBDCL_reglex _ ->
2414: bcat s ("//------------------------------\n");
2415: bcat s (
2416: gen_regexp_methods filename syms (child_map,bbdfns) label_info counter index ts instance_no
2417: )
2418:
2419: | `BBDCL_class _ ->
2420: bcat s ("//------------------------------\n");
2421: bcat s (
2422: gen_class_methods filename syms (child_map,bbdfns) label_info counter index ts instance_no
2423: )
2424:
2425: | _ -> ()
2426: end
2427: ;
2428: output_string bf (Buffer.contents s);
2429: Buffer.clear s
2430: )
2431: syms.instances
2432:
2433: let gen_biface_header syms bbdfns biface = match biface with
2434: | `BIFACE_export_fun (sr,index, export_name) ->
2435: let id,parent,sr,entry =
2436: try Hashtbl.find bbdfns index
2437: with Not_found -> failwith ("[gen_biface_header] Can't find index " ^ si index)
2438: in
2439: begin match entry with
2440: | `BBDCL_function (props,vs,(ps,traint), ret, _) ->
2441: let display = get_display_list bbdfns index in
2442: if length display <> 0
2443: then clierr sr "Can't export nested function";
2444:
2445: let argtypes =
2446: map
2447: (fun (_,(_,x)) -> cpp_typename syms x)
2448: ps
2449: in
2450: let arglist = " " ^
2451: (if length argtypes = 0 then "FLX_FPAR_DECL_ONLY"
2452: else "FLX_FPAR_DECL\n" ^ cat ",\n " argtypes
2453: )
2454: in
2455: let rettypename = cpp_typename syms ret in
2456:
2457: "//EXPORT FUNCTION " ^ cpp_instance_name syms bbdfns index [] ^
2458: " as " ^ export_name ^ "\n" ^
2459: "extern \"C\" FLX_EXPORT " ^ rettypename ^" " ^ export_name ^ "(\n" ^ arglist ^ "\n);\n"
2460:
2461: | `BBDCL_procedure (props,vs,(ps,traint), _) ->
2462: let display = get_display_list bbdfns index in
2463: if length display <> 0
2464: then clierr sr "Can't export nested proc";
2465:
2466: let argtypes =
2467: map
2468: (fun (_,(_,x)) -> cpp_typename syms x)
2469: ps
2470: in
2471: let arglist = " " ^
2472: (if length argtypes = 0 then "FLX_FPAR_DECL_ONLY"
2473: else "FLX_FPAR_DECL\n" ^ cat ",\n " argtypes
2474: )
2475: in
2476:
2477: "//EXPORT PROCEDURE " ^ cpp_instance_name syms bbdfns index [] ^
2478: " as " ^ export_name ^ "\n" ^
2479: "extern \"C\" FLX_EXPORT con_t * " ^ export_name ^ "(\n" ^ arglist ^ "\n);\n"
2480:
2481: | _ -> failwith "Not implemented: export non-function/procedure"
2482: end
2483:
2484: | `BIFACE_export_type (sr, typ, export_name) ->
2485: "//EXPORT type " ^ sbt syms.dfns typ ^ " as " ^ export_name ^ "\n" ^
2486: "typedef " ^ cpp_type_classname syms typ ^ " " ^ export_name ^ "_class;\n" ^
2487: "typedef " ^ cpp_typename syms typ ^ " " ^ export_name ^ ";\n"
2488:
2489: let gen_biface_body syms bbdfns biface = match biface with
2490: | `BIFACE_export_fun (sr,index, export_name) ->
2491: let id,parent,sr,entry =
2492: try Hashtbl.find bbdfns index
2493: with Not_found -> failwith ("[gen_biface_body] Can't find index " ^ si index)
2494: in
2495: begin match entry with
2496: | `BBDCL_function (props,vs,(ps,traint), ret, _) ->
2497: if length vs <> 0
2498: then clierr sr ("Can't export generic function " ^ id)
2499: ;
2500: let display = get_display_list bbdfns index in
2501: if length display <> 0
2502: then clierr sr "Can't export nested function";
2503:
2504: let argtypes =
2505: map
2506: (fun (id,(ix,t)) -> cpp_typename syms t ^ " " ^ id)
2507: ps
2508: in
2509: let arglist = " " ^
2510: (if length argtypes = 0 then "FLX_FPAR_DECL_ONLY"
2511: else "FLX_FPAR_DECL\n" ^ cat ",\n " argtypes
2512: )
2513: in
2514: (*
2515: if mem `Stackable props then print_endline ("Stackable " ^ export_name);
2516: if mem `Stack_closure props then print_endline ("Stack_closure" ^ export_name);
2517: *)
2518: let is_C_fun = mem `Pure props && not (mem `Heap_closure props) in
2519: let requires_ptf = mem `Requires_ptf props in
2520:
2521: let rettypename = cpp_typename syms ret in
2522: let class_name = cpp_instance_name syms bbdfns index [] in
2523:
2524: "//EXPORT FUNCTION " ^ class_name ^
2525: " as " ^ export_name ^ "\n" ^
2526: rettypename ^" " ^ export_name ^ "(\n" ^ arglist ^ "\n){\n" ^
2527: (if is_C_fun then
2528: " return " ^ class_name ^ "(" ^
2529: (
2530: if requires_ptf
2531: then "_PTFV" ^ (if length ps > 0 then "," else "")
2532: else ""
2533: )
2534: ^cat ", " (map fst ps) ^ ");\n"
2535: else
2536: " return (new(*_PTF gc,"^class_name^"_ptr_map)\n" ^
2537: " " ^ class_name ^ "(_PTFV)\n" ^
2538: " ->apply(" ^ cat ", " (map fst ps) ^ ");\n"
2539: )^
2540: "}\n"
2541:
2542: | `BBDCL_procedure (props,vs,(ps,traint),_) ->
2543: let stackable = mem `Stack_closure props in
2544: if length vs <> 0
2545: then clierr sr ("Can't export generic procedure " ^ id)
2546: ;
2547: let display = get_display_list bbdfns index in
2548: if length display <> 0
2549: then clierr sr "Can't export nested function";
2550:
2551: let argtypes =
2552: map
2553: (fun (id,(_,t)) -> cpp_typename syms t ^ " " ^ id)
2554: ps
2555: in
2556: let arglist = " " ^
2557: (if length argtypes = 0 then "FLX_FPAR_DECL_ONLY"
2558: else "FLX_FPAR_DECL\n" ^ cat ",\n " argtypes
2559: )
2560: in
2561: let class_name = cpp_instance_name syms bbdfns index [] in
2562:
2563: "//EXPORT PROC " ^ cpp_instance_name syms bbdfns index [] ^
2564: " as " ^ export_name ^ "\n" ^
2565: "con_t *" ^ export_name ^ "(\n" ^ arglist ^ "\n){\n" ^
2566: (
2567: if stackable then
2568: (
2569: if mem `Pure props && not (mem `Heap_closure props) then
2570: (
2571: " " ^ class_name ^"(" ^
2572: (
2573: if mem `Requires_ptf props then
2574: if length argtypes = 0
2575: then "FLX_APAR_PASS_ONLY "
2576: else "FLX_APAR_PASS "
2577: else ""
2578: )
2579: ^
2580: cat ", " (map fst ps) ^ ");\n"
2581: )
2582: else
2583: (
2584: " " ^ class_name ^ "(_PTFV)\n" ^
2585: " .stack_call(" ^ cat ", " (map fst ps) ^ ");\n"
2586: )
2587: )
2588: ^
2589: " return 0;\n"
2590: else
2591: " return (new(*_PTF gc,"^class_name^"_ptr_map)\n" ^
2592: " " ^ class_name ^ "(_PTFV))" ^
2593: "\n ->call(" ^ cat ", " ("0"::(map fst ps)) ^ ");\n"
2594: )
2595: ^
2596: "}\n"
2597:
2598: | _ -> failwith "Not implemented: export non-function/procedure"
2599: end
2600:
2601: | `BIFACE_export_type _ -> ""
2602:
2603: let gen_biface_headers syms bbdfns bifaces =
2604: cat "" (map (gen_biface_header syms bbdfns) bifaces)
2605:
2606: let gen_biface_bodies syms bbdfns bifaces =
2607: cat "" (map (gen_biface_body syms bbdfns) bifaces)
2608:
Start ocaml section to src/flxg.ml[1
/1
]
1: # 2671 "./lpsrc/flx_gen.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_srcref
9: open Flx_desugar
10: open Flx_bbind
11: open Flx_name
12: open Flx_tgen
13: open Flx_gen
14: open Flx_symtab
15: open Flx_getopt
16: open Flx_version
17: open Flx_exceptions
18: open Flx_flxopt
19: open Flx_ogen
20: open Flx_elkgen
21: ;;
22:
23: let print_help () = print_options(); exit(0)
24: ;;
25:
26: let reverse_return_parity = ref false
27: ;;
28:
29: let last_time = ref 0.0
30: ;;
31: let tim() =
32: let now = (Unix.times()).Unix.tms_utime in
33: let elapsed = now -. !last_time in
34: last_time := now;
35: elapsed
36: ;;
37:
38: let format_time tm =
39: si (tm.Unix.tm_year + 1900) ^ "/" ^
40: si (tm.Unix.tm_mon + 1) ^ "/" ^
41: si tm.Unix.tm_mday ^ " " ^
42: si tm.Unix.tm_hour ^ ":" ^
43: si tm.Unix.tm_min ^ ":" ^
44: si tm.Unix.tm_sec
45: ;;
46: try
47: (* Time initialisation *)
48: let compile_start = Unix.time () in
49: let compile_start_gm = Unix.gmtime compile_start in
50: let compile_start_local = Unix.localtime compile_start in
51: let compile_start_gm_string = format_time compile_start_gm ^ " UTC" in
52: let compile_start_local_string = format_time compile_start_local ^ " (local)" in
53:
54:
55: (* Argument parsing *)
56: let argc = Array.length Sys.argv in
57: if argc <= 1
58: then begin
59: print_endline "usage: flxg --key=value ... filename; -h for help";
60: exit 0
61: end
62: ;
63: let raw_options = parse_options Sys.argv in
64: let compiler_options = get_felix_options raw_options in
65: reverse_return_parity := compiler_options.reverse_return_parity
66: ;
67: let syms = make_syms compiler_options in
68: if check_keys raw_options ["h"; "help"]
69: then print_help ()
70: ;
71: if check_key raw_options "version"
72: then (print_endline ("Felix Version " ^ !version_data.version_string))
73: ;
74: if compiler_options.print_flag then begin
75: print_string "//Include directories = ";
76: List.iter (fun d -> print_string (d ^ " "))
77: compiler_options.include_dirs;
78: print_endline ""
79: end
80: ;
81:
82: (* main filename processing *)
83: let filename =
84: match get_key_value raw_options "" with
85: | Some s -> s
86: | None -> exit 0
87: in
88: let filebase = filename in
89: let input_file_name = filebase ^ ".flx"
90: and iface_file_name = filebase ^ ".fix"
91: and header_file_name = filebase ^ ".hpp"
92: and body_file_name = filebase ^ ".cpp"
93: and package_file_name = filebase ^ ".resh"
94: and rtti_file_name = filebase ^ ".rtti"
95: and report_file_name = filebase ^ ".xref"
96: and module_name =
97: let n = String.length filebase in
98: let i = ref (n-1) in
99: while !i <> -1 && filebase.[!i] <> '/' && filebase.[!i] <> '\\' do decr i done;
100: String.sub filebase (!i+1) (n - !i - 1)
101: in
102:
103: let include_dirs = (* (Filename.dirname input_file_name) :: *) compiler_options.include_dirs in
104: let compiler_options = { compiler_options with include_dirs = include_dirs } in
105: let syms = { syms with compiler_options = compiler_options } in
106:
107: (* PARSE THE IMPLEMENTATION FILE *)
108:
109: if compiler_options.print_flag
110: then print_endline ("//Parsing Implementation " ^ input_file_name);
111: let parse_tree =
112: Flx_desugar.include_file syms input_file_name false
113: in
114: if compiler_options.print_flag
115: then print_endline (Flx_print.string_of_compilation_unit parse_tree);
116:
117: let parse_time = tim() in
118: if compiler_options.print_flag
119: then print_endline ("//PARSE OK time " ^ string_of_float parse_time);
120:
121: if compiler_options.print_flag
122: then print_endline "//DESUGARING";
123:
124: let deblocked =
125: desugar_program syms module_name parse_tree
126: in
127: let desugar_time = tim() in
128: if compiler_options.print_flag
129: then print_endline ("//DESUGAR time " ^ string_of_float desugar_time);
130:
131: (* THIS IS A HACK! *)
132: let root = !(syms.counter) in
133: if compiler_options.print_flag
134: then print_endline ("//Top level module '"^module_name^"' has index " ^ si root);
135:
136:
137: if compiler_options.print_flag
138: then print_endline "//BUILDING TABLES";
139:
140: let pubtab, _, exes, ifaces,dirs =
141: build_tables syms "root" 0 None None root false deblocked
142: in
143: let build_table_time = tim() in
144: if compiler_options.print_flag
145: then print_endline ("//BUILDING TABLES time " ^ string_of_float build_table_time);
146:
147:
148: if compiler_options.print_flag
149: then print_endline "//BINDING EXECUTABLE CODE"
150: ;
151: let bbdfns = bbind syms in
152:
153: (* generate axiom checks *)
154: if compiler_options.generate_axiom_checks then
155: Flx_axiom.axiom_check syms bbdfns;
156:
157: let child_map = cal_children syms bbdfns in
158: syms.bifaces <- bind_ifaces syms ifaces;
159: Hashtbl.clear syms.ticache;
160:
161: let binding_time = tim() in
162:
163: if compiler_options.print_flag
164: then print_endline ("//Binding complete time " ^ string_of_float binding_time);
165:
166: if compiler_options.print_flag
167: then print_endline "//CHECKING ROOT";
168:
169: let root_proc =
170: match
171: try Hashtbl.find syms.dfns root
172: with Not_found ->
173: failwith
174: (
175: "Can't find root module " ^ si root ^
176: " in symbol table?"
177: )
178: with {id=id; sr=sr; parent=parent;vs=vs;pubmap=name_map;symdef=entry} ->
179: begin match entry with
180: | `SYMDEF_module -> ()
181: | _ -> failwith "Expected to find top level module ''"
182: end
183: ;
184: let entry =
185: try Hashtbl.find name_map "_init_"
186: with Not_found ->
187: failwith "Can't find name _init_ in top level module's name map"
188: in
189: let index = match entry with
190: | FunctionEntry [x] -> x
191: | FunctionEntry [] -> failwith "Couldn't find '_init_'"
192: | FunctionEntry _ -> failwith "Too many top level procedures called '_init_'"
193: | NonFunctionEntry _ -> failwith "_init_ found but not procedure"
194: in
195: if compiler_options.print_flag
196: then print_endline ("//root module's init procedure has index " ^ si index);
197: index
198: in
199:
200: if compiler_options.print_flag
201: then print_endline "//OPTIMISING";
202: let () = Flx_use.find_roots syms bbdfns root_proc syms.bifaces in
203: let bbdfns = Flx_use.copy_used syms bbdfns in
204: let child_map = cal_children syms bbdfns in
205:
206: if compiler_options.max_inline_length > 0 then
207: begin
208: (*
209: print_functions syms.dfns !bbdfns;
210: *)
211: if compiler_options.print_flag then
212: print_endline "//INLINING";
213:
214: syms.reductions <- List.filter
215: (fun (id,bvs,bps,e1,_) ->
216: let psi = List.map (fun (_,(i,_)) -> i) bps in
217: let ui i =
218: let used = List.mem i psi or Hashtbl.mem bbdfns i in
219: if not used then begin
220: if compiler_options.print_flag then
221: print_endline ("ELIDING USELESS REDUCTION " ^ id ^ " because " ^ si i ^ " isn't found");
222: raise Not_found
223: end
224: in
225: begin
226: try
227: Flx_maps.iter_tbexpr ui ignore ignore e1;
228: true
229: with
230: | Not_found -> false
231: end
232: )
233: syms.reductions
234: ;
235: Flx_inline.heavy_inlining syms (child_map,bbdfns);
236: (*
237: print_endline "INLINING DONE: RESULT:";
238: print_functions syms.dfns bbdfns;
239: *)
240: end
241: ;
242: let bbdfns = Flx_use.copy_used syms bbdfns in
243: let child_map = cal_children syms bbdfns in
244:
245: let elim_init maybe_unused exes =
246: List.filter (function
247: | `BEXE_init (_,i,_) -> not (IntSet.mem i maybe_unused)
248: | _ -> true
249: )
250: exes
251: in
252: let elim_pass () =
253: (* check for unused things .. possible, just a diagnostic for now *)
254: let full_use = Flx_use.full_use_closure syms bbdfns in
255: let partial_use = Flx_use.cal_use_closure syms bbdfns false in
256: let maybe_unused = IntSet.diff full_use partial_use in
257:
258: Hashtbl.iter
259: (fun i (id,parent,sr,entry) -> match entry with
260: | `BBDCL_procedure (props ,bvs,(ps,tr),exes) ->
261: let exes = elim_init maybe_unused exes in
262: let entry = `BBDCL_procedure (props,bvs,(ps,tr),exes) in
263: Hashtbl.replace bbdfns i (id,parent,sr,entry)
264:
265: | `BBDCL_function (props,bvs,(ps,rt),ret,exes) ->
266: let exes = elim_init maybe_unused exes in
267: let entry = `BBDCL_function (props,bvs,(ps,rt),ret,exes) in
268: Hashtbl.replace bbdfns i (id,parent,sr,entry)
269:
270: | `BBDCL_glr (props,bvs,ret,(p,exes)) ->
271: let exes = elim_init maybe_unused exes in
272: let entry = `BBDCL_glr (props,bvs,ret,(p,exes)) in
273: Hashtbl.replace bbdfns i (id,parent,sr,entry)
274: | _ -> ()
275: )
276: bbdfns
277: ;
278:
279: IntSet.iter
280: (fun i->
281: let id,_,_,_ = Hashtbl.find bbdfns i in
282: if compiler_options.print_flag then
283: print_endline ("Removing unused " ^ id ^ "<" ^ si i ^ ">");
284: Hashtbl.remove bbdfns i
285: )
286: maybe_unused
287: ;
288: IntSet.is_empty maybe_unused
289: in
290:
291: while not (elim_pass ()) do () done;
292:
293:
294: (*
295: print_functions syms.dfns bbdfns;
296: *)
297:
298: if compiler_options.print_flag
299: then print_endline "//Calculating stackable calls";
300: let label_map = Flx_label.create_label_map bbdfns syms.counter in
301: let label_usage = Flx_label.create_label_usage syms bbdfns label_map in
302: let label_info = label_map, label_usage in
303:
304: Flx_stack_calls.make_stack_calls syms (child_map,bbdfns);
305:
306: let opt_time = tim() in
307:
308: if compiler_options.print_flag
309: then print_endline ("//Optimisation complete time " ^ string_of_float opt_time);
310:
311:
312: if compiler_options.print_flag
313: then print_endline "//Generating primitive wrapper closures";
314: Flx_mkcls.make_closures syms bbdfns;
315: let child_map = cal_children syms bbdfns in
316:
317: if compiler_options.print_flag then
318: begin
319: let f = open_out report_file_name in
320: Flx_call.print_call_report syms bbdfns f;
321: close_out f
322: end
323: ;
324:
325: if compiler_options.print_flag
326: then print_endline "//Finding which functions use globals";
327: let bbdfns = Flx_use.copy_used syms bbdfns in
328: Flx_global.set_globals syms bbdfns;
329:
330: if compiler_options.print_flag
331: then print_endline "//instantiating";
332:
333: Flx_inst.instantiate syms bbdfns root_proc syms.bifaces;
334: let top_class =
335: try cpp_instance_name syms bbdfns root_proc []
336: with Not_found ->
337: failwith ("can't name instance of root _init_ procedure index " ^ si root_proc)
338: in
339:
340: (* fix up root procedures so if they're not stackable,
341: then they need a heap closure -- wrappers require
342: one or the other
343: *)
344: IntSet.iter (fun i ->
345: let id,parent,sr,entry = Hashtbl.find bbdfns i in
346: match entry with
347: | `BBDCL_procedure (props,vs,p,exes) ->
348: let props = ref props in
349: if List.mem `Stackable !props then begin
350: if not (List.mem `Stack_closure !props)
351: then props := `Stack_closure :: !props
352: end else begin
353: if not (List.mem `Heap_closure !props)
354: then props := `Heap_closure :: !props
355: end
356: ;
357: if not (List.mem `Requires_ptf !props)
358: then props := `Requires_ptf :: !props
359: ;
360: let entry = `BBDCL_procedure (!props, vs,p,exes) in
361: Hashtbl.replace bbdfns i (id,parent,sr,entry)
362: | _ -> ()
363:
364: )
365: !(syms.roots)
366: ;
367: (* FUDGE the init procedure to make interfacing a bit simpler *)
368: let topclass_props =
369: let id,parent,sr,entry = Hashtbl.find bbdfns root_proc in
370: match entry with
371: | `BBDCL_procedure (props,vs,p,exes) -> props
372: | _ -> syserr sr "Expected root to be procedure"
373: in
374: if compiler_options.print_flag
375: then print_endline ("//root module's init procedure has name " ^
376: top_class
377: );
378:
379: let instantiation_time = tim() in
380:
381: if compiler_options.print_flag
382: then print_endline ("//instantiation time " ^ string_of_float instantiation_time);
383:
384: if compiler_options.compile_only
385: then exit (if compiler_options.reverse_return_parity then 1 else 0)
386: ;
387:
388: begin let cnt = ref 1 in
389: let find_parsers this e = match e with
390: | `BEXPR_parse ((_,t') as e,ii),_ ->
391: if not (Hashtbl.mem syms.parsers (this,t',ii)) then begin
392: let n = !cnt in incr cnt;
393: Hashtbl.add syms.parsers (this,t',ii) n;
394: (*
395: print_endline ("PARSER " ^ si n)
396: *)
397: end
398: ;
399: if not (Hashtbl.mem syms.lexers (this,e)) then begin
400: let n = !cnt in incr cnt;
401: Hashtbl.add syms.lexers (this,e) n;
402: (*
403: print_endline ("LEXER " ^ si n ^ " = " ^ sbe syms.dfns e);
404: *)
405: end
406: | _ -> ()
407: in
408:
409: let nul x = () in
410: Hashtbl.iter
411: (fun i (_,_,_,entry) -> match entry with
412: | `BBDCL_function (_,_,_,_,exes)
413: | `BBDCL_procedure (_,_,_,exes) ->
414: List.iter (Flx_maps.iter_bexe nul (find_parsers i) nul nul nul) exes
415: | _ -> ()
416: )
417: bbdfns
418: end
419: ;
420:
421: let sr = ("unknown",0,0,0,0) in
422: Hashtbl.iter
423: (fun (this,t',ii) n -> gen_elk_parser filebase module_name syms bbdfns this sr t' n ii)
424: syms.parsers
425: ;
426:
427: Hashtbl.iter
428: (fun (this,e) n -> gen_elk_lexer filebase module_name syms bbdfns this sr e n)
429: syms.lexers
430: ;
431:
432: let hf = open_out header_file_name in
433: let bf = open_out body_file_name in
434: let pf = open_out package_file_name in
435: let rf = open_out rtti_file_name in
436: let psh s = output_string hf s in
437: let psb s = output_string bf s in
438: let psp s = output_string pf s in
439: let psr s = output_string rf s in
440: let plh s = psh s; psh "\n" in
441: let plb s = psb s; psb "\n" in
442: let plr s = psr s; psr "\n" in
443: let plp s = psp s; psp "\n" in
444:
445: if compiler_options.print_flag
446: then print_endline "//GENERATING Package Requirements";
447:
448: (* These must be in order: build a list and sort it *)
449: begin
450: let dfnlist = ref [] in
451: Hashtbl.iter
452: (fun (i,ts) _ -> dfnlist := (i,ts) :: !dfnlist)
453: syms.instances
454: ;
455: let insts = Hashtbl.create 97 in
456: List.iter
457: (fun (i,ts)->
458: match
459: try Hashtbl.find bbdfns i
460: with Not_found -> failwith ("[package] can't find index " ^ si i)
461: with (id,parent,sr,entry) ->
462: match entry with
463: | `BBDCL_insert (_,s,`Package,_) ->
464: begin match s with
465: | `Str "" | `StrTemplate "" -> ()
466: | _ ->
467: let s =
468: match s with
469: | `Str s -> Flx_cexpr.ce_expr "atom" s
470: | `StrTemplate s ->
471: (* do we need tsubst vs ts t? *)
472: let tn t = cpp_typename syms (Flx_typing.lower t) in
473: let ts = List.map tn ts in
474: Flx_csubst.csubst sr sr s (Flx_cexpr.ce_atom "Error") [] [] "Error" "Error" ts "atom" "Error" ["Error"] ["Error"] ["Error"]
475: in
476: let s = Flx_cexpr.sc "expr" s in
477: if not (Hashtbl.mem insts s) then
478: begin
479: Hashtbl.add insts s ();
480: plp s
481: end
482: end
483: | _ -> ()
484: )
485: (List.sort compare !dfnlist)
486: end
487: ;
488:
489:
490: if compiler_options.print_flag
491: then print_endline "//GENERATING C++: user headers";
492:
493: plh ("#ifndef _FLX_GUARD_" ^ module_name);
494: plh ("#define _FLX_GUARD_" ^ module_name);
495: plh ("//Input file: " ^ input_file_name);
496: plh ("//Generated by Felix Version " ^ !version_data.version_string);
497: plh ("//Timestamp: " ^ compile_start_gm_string);
498: plh ("//Timestamp: " ^ compile_start_local_string);
499: plh "";
500: plh "//FELIX RUNTIME";
501: plh "#include \"flx_rtl.hpp\"";
502: plh "using namespace flx::rtl;";
503: plh "#include \"flx_gc.hpp\"";
504: plh "using namespace flx::gc::generic;";
505: plh "";
506:
507: plh "\n//-----------------------------------------";
508: plh "//USER HEADERS";
509: (* These must be in order: build a list and sort it *)
510: begin
511: let dfnlist = ref [] in
512: Hashtbl.iter
513: (fun (i,ts) _ -> dfnlist := (i,ts) :: !dfnlist)
514: syms.instances
515: ;
516: let insts = Hashtbl.create 97 in
517: List.iter
518: (fun (i,ts)->
519: match
520: try Hashtbl.find bbdfns i
521: with Not_found -> failwith ("[user header] can't find index " ^ si i)
522: with (id,parent,sr,entry) ->
523: match entry with
524: | `BBDCL_insert (_,s,`Header,_) ->
525: begin match s with
526: | `Str "" | `StrTemplate "" -> ()
527: | _ ->
528: let s =
529: match s with
530: | `Str s -> Flx_cexpr.ce_expr "atom" s
531: | `StrTemplate s ->
532: (* do we need tsubst vs ts t? *)
533: let tn t = cpp_typename syms (Flx_typing.lower t) in
534: let ts = List.map tn ts in
535: Flx_csubst.csubst sr sr s (Flx_cexpr.ce_atom "Error") [] [] "Error" "Error" ts "atom" "Error" ["Error"] ["Error"] ["Error"]
536: in
537: let s = Flx_cexpr.sc "expr" s in
538: if not (Hashtbl.mem insts s) then
539: begin
540: Hashtbl.add insts s ();
541: plh s
542: end
543: end
544: | _ -> ()
545: )
546: (List.sort compare !dfnlist)
547: end
548: ;
549:
550: (* HACKERY FOR ELKHOUND -- we force include library files
551: into the global namespace, macro guards should prevent
552: subsequent inclusion in the module namespace
553: *)
554: if Hashtbl.length syms.lexers <> 0 then begin
555: plh "#include \"elk_lexerint.h\""
556: end
557: ;
558:
559: if Hashtbl.length syms.parsers <> 0 then begin
560: plh "#include \"elk_useract.h\""
561: end
562: ;
563:
564: plh "\n//-----------------------------------------";
565: List.iter plh [
566: "//FELIX SYSTEM";
567: "namespace flxusr { namespace "^module_name^ " {";
568: "struct thread_frame_t;"
569: ]
570: ;
571: if compiler_options.print_flag then
572: print_endline "//GENERATING C++: collect types";
573: let types = ref [] in
574: Hashtbl.iter
575: (fun t index-> types := (index, t) :: !types)
576: syms.registry
577: ;
578: let types =
579: List.sort
580: (
581: fun a1 a2 -> compare (fst a1) (fst a2)
582: )
583: !types
584: in
585: (*
586: List.iter
587: (fun (_,t) -> print_endline (string_of_btypecode dfns t))
588: types
589: ;
590: *)
591:
592: if compiler_options.print_flag then
593: print_endline "//GENERATING C++: type class names";
594: plh "\n//-----------------------------------------";
595: plh "//NAME THE TYPES";
596: plh (gen_type_names syms bbdfns types);
597:
598: if compiler_options.print_flag then
599: print_endline "//GENERATING C++: type class definitions";
600: plh "\n//-----------------------------------------";
601: plh "//DEFINE THE TYPES";
602: plh (gen_types syms bbdfns types);
603:
604: if not (Hashtbl.length syms.parsers + Hashtbl.length syms.lexers = 0) then begin
605: plp "elk";
606: plh "\n//-----------------------------------------";
607: plh "//ELKHOUND OBJECTS, forward declaration";
608: Hashtbl.iter
609: (fun _ n -> plh ("struct ElkLex_"^si n^";"))
610: syms.lexers
611: ;
612: Hashtbl.iter
613: (fun _ n -> plh ("struct Elk_"^si n^";"))
614: syms.parsers
615: end
616: ;
617: if compiler_options.print_flag then
618: print_endline "//GENERATING C++: function and procedure classes";
619: plh "\n//-----------------------------------------";
620: plh "//DEFINE FUNCTION CLASSES";
621: plh (gen_functions syms (child_map,bbdfns));
622:
623: if not (Hashtbl.length syms.parsers + Hashtbl.length syms.lexers = 0) then begin
624: plh "\n//-----------------------------------------";
625: plh "//INCLUDE ELKHOUND PARSERS";
626: Hashtbl.iter
627: (fun _ n -> plh ("#include \""^module_name^"_lexer_"^si n^".hpp\""))
628: syms.lexers
629: ;
630: Hashtbl.iter
631: (fun _ n -> plh ("#include \""^module_name^"_parser_"^si n^".h\""))
632: syms.parsers
633: end
634: ;
635:
636: let topvars_with_type = find_thread_vars_with_type bbdfns in
637: let topvars = List.map fst topvars_with_type in
638: List.iter plh
639: [
640: "struct thread_frame_t {";
641: " int argc;";
642: " char **argv;";
643: " FILE *flx_stdin;";
644: " FILE *flx_stdout;";
645: " FILE *flx_stderr;";
646: " collector_t *gc;";
647: " thread_frame_t(";
648: " collector_t*";
649: " );";
650: ]
651: ;
652: plh (format_vars syms bbdfns topvars []);
653: plh "};";
654: plh "";
655: plh "FLX_DCL_THREAD_FRAME";
656: plh "";
657: plh ("}} // namespace flxusr::" ^ module_name);
658:
659: (* BODY *)
660: if compiler_options.print_flag then
661: print_endline "//GENERATING C++: GC ptr maps & offsets";
662:
663: plb ("//Input file: " ^ input_file_name);
664: plb ("//Generated by Felix Version " ^ !version_data.version_string);
665: plb ("//Timestamp: " ^ compile_start_gm_string);
666: plb ("//Timestamp: " ^ compile_start_local_string);
667:
668: plb ("#include \"" ^ module_name ^ ".hpp\"");
669: plb "#include <stdio.h>"; (* for diagnostics *)
670:
671: if Hashtbl.length syms.parsers <> 0 then begin
672: plb "#include \"elk_glr.h\""
673: end
674: ;
675:
676: plb "#define comma ,";
677: plb "#define ifnot(x) if(!(x))";
678: plb "\n//-----------------------------------------";
679: plb "//EMIT USER BODY CODE";
680: (* These must be in order: build a list and sort it *)
681: begin
682: let dfnlist = ref [] in
683: Hashtbl.iter
684: (fun (i,ts) _ -> dfnlist := (i,ts) :: !dfnlist)
685: syms.instances
686: ;
687: let insts = Hashtbl.create 97 in
688: List.iter
689: (fun (i,ts) ->
690: match
691: try Hashtbl.find bbdfns i
692: with Not_found -> failwith ("[user body] can't find index " ^ si i)
693: with (id,parent,sr,entry) ->
694: match entry with
695: | `BBDCL_insert (_,s,`Body,_) ->
696: begin match s with
697: | `Str "" | `StrTemplate "" -> ()
698: | _ ->
699: let s =
700: match s with
701: | `Str s -> Flx_cexpr.ce_expr "atom" s
702: | `StrTemplate s ->
703: (* do we need tsubst vs ts t? *)
704: let tn t = cpp_typename syms (Flx_typing.lower t) in
705: let ts = List.map tn ts in
706: Flx_csubst.csubst sr sr s (Flx_cexpr.ce_atom "Error") [] [] "Error" "Error" ts "atom" "Error" ["Error"] ["Error"] ["Error"]
707: in
708: let s = Flx_cexpr.sc "expr" s in
709: if not (Hashtbl.mem insts s) then
710: begin
711: Hashtbl.add insts s ();
712: plb s
713: end
714: end
715: | _ -> ()
716: )
717: (List.sort compare !dfnlist)
718: end
719: ;
720:
721: plb "\n//-----------------------------------------";
722: plb ("namespace flxusr { namespace " ^ module_name ^ " {");
723:
724: plb "FLX_DEF_THREAD_FRAME";
725: plb "//Thread Frame Constructor";
726:
727: let sr = "Thread Frame",0,0,0,0 in
728: let topfuns = List.filter (fun (_,t) -> is_gc_pointer syms bbdfns sr t) topvars_with_type in
729: let topfuns = List.map fst topfuns in
730: let topinits =
731: [
732: " gc(gc_a)"
733: ]
734: @
735: List.map
736: (fun index ->
737: " " ^
738: cpp_instance_name syms bbdfns index [] ^
739: "(0)"
740: )
741: topfuns
742: in
743: let topinits = String.concat ",\n" topinits in
744: List.iter plb
745: [
746: "thread_frame_t::thread_frame_t(";
747: " collector_t *gc_a";
748: ") :";
749: topinits;
750: "{}"
751: ];
752:
753:
754:
755: plb "\n//-----------------------------------------";
756: plb "//DEFINE OFFSET tables for GC";
757: plb ("#include \""^module_name^".rtti\"");
758: plr "//DEFINE OFFSET tables for GC";
759:
760: plr (Flx_ogen.gen_offset_tables syms (child_map,bbdfns) module_name);
761:
762: plb "\n//-----------------------------------------";
763: plb "#ifdef FLX_CGOTO";
764: plb "//DEFINE LABELS for GNUC ASSEMBLER LABEL HACK";
765: Hashtbl.iter
766: (fun (fno,_) inst ->
767: try
768: let labels = Hashtbl.find label_map fno in
769: Hashtbl.iter
770: (fun lab lno ->
771: match Flx_label.get_label_kind_from_index label_usage lno with
772: | `Far ->
773: plb ("FLX_DECLARE_LABEL(" ^ si lno ^ ","^ si inst ^ "," ^ lab^")")
774: | `Near -> ()
775: | `Unused -> ()
776: )
777: labels
778: with Not_found -> ()
779: )
780: syms.instances
781: ;
782: plb "#endif";
783:
784: if not (Hashtbl.length syms.parsers + Hashtbl.length syms.lexers = 0) then begin
785: plb "\n//-----------------------------------------";
786: plb "//INCLUDE ELKHOUND PARSERS";
787: Hashtbl.iter
788: (fun _ n -> plb ("#include \""^module_name^"_lexer_"^si n^".cpp\""))
789: syms.lexers
790: ;
791:
792: plb "#include \"elk_glr.h\"";
793: Hashtbl.iter
794: (fun _ n -> plb ("#include \""^module_name^"_parser_"^si n^".cc\""))
795: syms.parsers
796: end
797: ;
798:
799: if compiler_options.print_flag then
800: print_endline "//GENERATING C++: method bodies";
801:
802: plb "\n//-----------------------------------------";
803: plb "//DEFINE FUNCTION CLASS METHODS";
804: gen_execute_methods body_file_name syms (child_map,bbdfns) label_info syms.counter bf;
805:
806: if compiler_options.print_flag then print_endline "//GENERATING C++: interface";
807: plb "\n//-----------------------------------------";
808: plb ("}} // namespace flxusr::" ^ module_name);
809:
810: plb "//CREATE STANDARD EXTERNAL INTERFACE";
811: plb ("FLX_FRAME_WRAPPERS(flxusr::"^module_name^")");
812: (if List.mem `Pure topclass_props then
813: plb ("FLX_C_START_WRAPPER(flxusr::"^module_name^","^top_class^")")
814: else if List.mem `Stackable topclass_props then
815: plb ("FLX_STACK_START_WRAPPER(flxusr::"^module_name^","^top_class^")")
816: else
817: plb ("FLX_START_WRAPPER(flxusr::"^module_name^","^top_class^")")
818: );
819: plb "\n//-----------------------------------------";
820:
821: plh ("using namespace flxusr::" ^ module_name ^ ";");
822: if List.length syms.bifaces > 0 then begin
823: plh "//DECLARE USER EXPORTS";
824: plh (gen_biface_headers syms bbdfns syms.bifaces);
825: plb "//DEFINE EXPORTS";
826: plb (gen_biface_bodies syms bbdfns syms.bifaces);
827: end
828: ;
829:
830: (* rather late: generate variant remapping tables *)
831: if Hashtbl.length syms.variant_map > 0 then begin
832: plr "// VARIANT REMAP ARRAYS";
833: Hashtbl.iter
834: (fun (srct,dstt) vidx ->
835: match srct,dstt with
836: | `BTYP_variant srcls, `BTYP_variant dstls ->
837: begin
838: let rcmp (s,_) (s',_) = compare s s' in
839: let srcls = List.sort rcmp srcls in
840: let dstls = List.sort rcmp dstls in
841: let n = List.length srcls in
842: let remap =
843: List.map
844: (fun (s,_) ->
845: match Flx_util.list_assoc_index dstls s with
846: | Some i -> i
847: | None -> assert false
848: )
849: srcls
850: in
851: plr ("static int vmap_" ^ si vidx^ "["^si n^"]={" ^
852: catmap "," (fun i -> si i) remap ^
853: "};")
854: end
855: | _ -> failwith "Remap non variant types??"
856: )
857: syms.variant_map
858: end
859: ;
860: plh "//header complete";
861: plh "#endif";
862: plb "//body complete";
863: close_out hf;
864: close_out bf;
865: plp "flx";
866: plp "flx_gc"; (* RF: flx apps now need flx_gc. is this the way to do it? *)
867: close_out pf;
868: close_out rf;
869: let code_generation_time = tim() in
870: if compiler_options.print_flag then
871: print_endline ("//code generation time " ^ string_of_float code_generation_time);
872:
873: let total_time =
874: parse_time +.
875: desugar_time +.
876: build_table_time +.
877: binding_time +.
878: opt_time +.
879: instantiation_time +.
880: code_generation_time
881: in
882: if compiler_options.print_flag then
883: print_endline ("//Felix compiler time " ^ string_of_float total_time);
884: let fname = "flxg_stats.txt" in
885: let
886: old_parse_time,
887: old_desugar_time,
888: old_build_table_time,
889: old_binding_time,
890: old_opt_time,
891: old_instantiation_time,
892: old_code_generation_time,
893: old_total_time
894: =
895: let zeroes = 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0 in
896: let f = try Some (open_in fname) with _ -> None in
897: begin match f with
898: | None -> zeroes
899: | Some f ->
900: let x =
901: try
902: let id x1 x2 x3 x4 x5 x6 x7 x8 = x1, x2, x3, x4, x5, x6, x7, x8 in
903: Scanf.fscanf f
904: "parse=%f desugar=%f build=%f bind=%f opt=%f inst=%f gen=%f tot=%f"
905: id
906: with _ -> zeroes
907: in close_in f; x
908: end
909: in
910: let f = open_out fname in
911: Printf.fprintf
912: f
913: "parse=%f\ndesugar=%f\nbuild=%f\nbind=%f\nopt=%f\ninst=%f\ngen=%f\ntot=%f\n"
914: (old_parse_time +. parse_time)
915: (old_desugar_time +. desugar_time)
916: (old_build_table_time +. build_table_time)
917: (old_binding_time +. binding_time)
918: (old_opt_time +. opt_time)
919: (old_instantiation_time +. instantiation_time)
920: (old_code_generation_time +. code_generation_time)
921: (old_total_time +. total_time)
922: ;
923: close_out f
924: ;
925: exit (if compiler_options.reverse_return_parity then 1 else 0)
926:
927: with x -> Flx_terminate.terminate !reverse_return_parity x
928: ;;
929: