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