1: # 31 "./lpsrc/flx_ogen.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_mtypes1
6: open Flx_mtypes2
7: open Flx_name
8: open Flx_unify
9: open Flx_typing
10: open Flx_tgen
11: open List
12: open Flx_print
13: open Flx_exceptions
14: open Flx_maps
15:
16: let find_thread_vars_with_type bbdfns =
17: let vars = ref [] in
18: Hashtbl.iter
19: (fun k (id,parent,sr,entry) ->
20: match parent,entry with
21: | None,`BBDCL_var (_,t)
22: | None,`BBDCL_val (_,t)
23: -> vars := (k,t) :: !vars
24: | None,`BBDCL_ref (_,t)
25: -> vars := (k,`BTYP_pointer t) :: !vars
26:
27: | _ -> ()
28: )
29: bbdfns
30: ;
31: !vars
32:
33:
34: let find_references syms (child_map,bbdfns) index ts =
35: let children =
36: try
37: Hashtbl.find child_map index
38: with Not_found -> []
39: in
40: let references = ref [] in
41: iter
42: (fun idx ->
43: try
44: let id,_,_,bbdfn =
45: Hashtbl.find bbdfns idx
46: in
47: match bbdfn with
48: | `BBDCL_var (vs,t)
49: | `BBDCL_ref (vs,t)
50: | `BBDCL_val (vs,t)
51: ->
52: if length ts <> length vs then
53: failwith
54: (
55: "[find_references] entry " ^ si index ^
56: ", child " ^ id ^ "<" ^ si idx ^ ">" ^
57: ", wrong number of args, expected vs = " ^
58: si (length vs) ^
59: ", got ts=" ^
60: si (length ts)
61: );
62: let t = reduce_type (tsubst vs ts (lower t)) in
63: references := (idx,t) :: !references
64: | _ -> ()
65: with Not_found -> ()
66: )
67: children
68: ;
69: rev (!references)
70:
71: let comma_sub s =
72: let rec aux l r =
73: try (* note: breaks tail recursion optimisation *)
74: let i = String.index r ',' in
75: let n = String.length r in
76: aux (l ^ String.sub r 0 i ^ " comma ") (String.sub r (i+1) (n-i-1))
77: with Not_found -> l ^ r
78: in
79: aux "" s
80:
81: (* this code handles pointers in types *)
82: let rec get_offsets' syms bbdfns typ : string list =
83: let typ = reduce_type (lstrip syms.dfns typ) in
84: let tname = cpp_typename syms typ in
85: let t' = unfold syms.dfns typ in
86: match t' with
87:
88: | `BTYP_lift _ -> assert false
89:
90: | `BTYP_pointer t ->
91: ["offsetof("^tname^",frame)"]
92:
93: | `BTYP_sum args when not (all_units args) ->
94: ["offsetof("^tname^",data)"]
95:
96: (* need to fix the rule for optimisation here .. *)
97: | `BTYP_variant _ ->
98: ["offsetof("^tname^",data)"]
99:
100: | `BTYP_inst (i,ts) ->
101: let id,parent,sr,entry =
102: try Hashtbl.find bbdfns i
103: with Not_found -> failwith ("get_offsets'] can't find index " ^ si i)
104: in
105: begin match entry with
106: | `BBDCL_union (vs,idts) ->
107: let varmap = mk_varmap vs ts in
108: let cpts = map (fun (_,_,t) -> varmap_subst varmap t) idts in
109: if all_voids cpts then []
110: else ["offsetof("^tname^",data)"]
111:
112: | `BBDCL_struct (vs,idts) ->
113: let varmap = mk_varmap vs ts in
114: let n = ref 0 in
115: let cpts = map (fun (s,t) -> s,varmap_subst varmap t) idts in
116: let lst = ref [] in
117: iter
118: (fun (s,t) ->
119: let prefix =
120: "offsetof("^tname^","^s^")+"
121: in
122: iter
123: (fun s -> lst := !lst @ [prefix ^ s])
124: (get_offsets' syms bbdfns t)
125: )
126: cpts
127: ;
128: !lst
129:
130: | `BBDCL_class _ -> ["0"]
131:
132: | `BBDCL_abs (vs,type_quals,_,_)
133: when mem `GC_pointer type_quals -> ["0"]
134:
135: | _ -> []
136: end
137:
138: | `BTYP_array (t,`BTYP_void ) -> []
139: | `BTYP_array (t,`BTYP_unitsum k) ->
140: let toffsets = get_offsets' syms bbdfns t in
141: if toffsets = [] then [] else
142: if k> 100 then
143: failwith ("[get_offsets] Too many elements in array for shape, type " ^ sbt syms.dfns t')
144: else begin
145: let eltype = cpp_typename syms t in
146: fold_left
147: (fun result i ->
148: let ss = "+" ^ si i ^ "*sizeof("^eltype^")" in
149: fold_left
150: (fun result s -> (s ^ ss) :: result)
151: result
152: toffsets
153: )
154: []
155: (nlist k)
156: end
157:
158: | `BTYP_tuple args ->
159: let n = ref 0 in
160: let lst = ref [] in
161: iter
162: (fun t ->
163: let prefix =
164: "offsetof("^tname^",mem_"^si !n^")+"
165: in
166: iter
167: (fun s -> lst := !lst @ [prefix ^ s])
168: (get_offsets' syms bbdfns t)
169: ;
170: incr n
171: )
172: args
173: ;
174: !lst
175:
176: | `BTYP_record args ->
177: let lst = ref [] in
178: iter
179: (fun (s,t) ->
180: let prefix =
181: "offsetof("^tname^","^s^")+"
182: in
183: iter
184: (fun s -> lst := !lst @ [prefix ^ s])
185: (get_offsets' syms bbdfns t)
186: )
187: args
188: ;
189: !lst
190:
191: | `BTYP_function _ -> ["0"]
192: | `BTYP_cfunction _ -> []
193:
194: | `BTYP_unitsum _ -> []
195:
196: | `BTYP_intersect _
197: -> failwith "[ogen] Type intersection has no representation"
198:
199: (* this is a lie .. it does, namely a plain C union *)
200: | `BTYP_typeset _
201: -> failwith "[ogen] Type set has no representation"
202:
203: | `BTYP_sum _
204: | `BTYP_array _
205: | `BTYP_lvalue _
206: | `BTYP_fix _
207: | `BTYP_void
208: | `BTYP_var _
209:
210: | `BTYP_case _
211: | `BTYP_apply _
212: | `BTYP_type _
213: | `BTYP_typefun _
214: | `BTYP_type_tuple _
215: | `BTYP_type_match _
216: | `BTYP_typesetintersection _
217: | `BTYP_typesetunion _
218: -> assert false
219:
220: let get_offsets syms bbdfns typ =
221: map (fun s -> s^",") (get_offsets' syms bbdfns typ)
222:
223: let gen_offset_data s n name offsets isfun props flags last_ptr_map =
224: let this_ptr_map = name ^ "_ptr_map" in
225: let old_ptr_map = !last_ptr_map in
226: last_ptr_map := "&"^this_ptr_map;
227: let noffsets =
228: if isfun && mem `Requires_ptf props then si (n-1)^"+FLX_PASS_PTF"
229: else si n
230: in
231: if n <> 0 then
232: begin
233: bcat s ("static std::size_t " ^ name ^
234: "_offsets["^noffsets^ "]={\n");
235: bcat s (" " ^ cat "\n " offsets);
236: bcat s ("\n" ^ "};\n");
237: end;
238: bcat s ("FLX_FINALISER("^name^")\n");
239: bcat s ( "static gc_shape_t "^ this_ptr_map ^" (\n");
240: bcat s (" " ^ old_ptr_map ^ ",\n");
241: bcat s (" \"" ^ name ^ "\",\n");
242: bcat s (" 1,sizeof("^name^"),\n "^name^"_finaliser,\n");
243: bcat s (" "^noffsets^",\n "^ (if n<>0 then name^"_offsets" else "0"));
244: bcat s (match flags with None -> "\n" | Some flags -> ",\n " ^ flags^"\n");
245: bcat s ( ");\n")
246:
247: let is_instantiated syms i ts = Hashtbl.mem syms.instances (i,ts)
248:
249: let gen_fun_offsets s syms (child_map,bbdfns) index vs ps ret ts instance props last_ptr_map : unit =
250: let vars = (find_references syms (child_map,bbdfns) index ts) in
251: let vars = filter (fun (i, _) -> is_instantiated syms i ts) vars in
252: let name = cpp_instance_name syms bbdfns index ts in
253: let display = Flx_display.get_display_list syms bbdfns index in
254: let offsets =
255: (if mem `Requires_ptf props then
256: ["FLX_EAT_PTF(offsetof(" ^ name ^ ",ptf)comma)"]
257: else []
258: )
259: @
260: (match ret with
261: | `BTYP_void -> [ ("offsetof(" ^ name ^ ",_caller),") ]
262: | _ -> []
263: )
264: @
265: map
266: (fun (didx, vslen) ->
267: let dptr = "ptr" ^ cpp_instance_name syms bbdfns didx (list_prefix ts vslen) in
268: "offsetof("^name^","^dptr^"),"
269: )
270: display
271: @
272: concat
273: (
274: map
275: (fun (idx,typ)->
276: let mem = cpp_instance_name syms bbdfns idx ts in
277: let offsets = get_offsets syms bbdfns typ in
278: map
279: (fun offset ->
280: "offsetof("^name^","^mem^")+" ^ offset
281: )
282: offsets
283: )
284: vars
285: )
286: in
287: let n = length offsets in
288: bcat s
289: (
290: "\n//OFFSETS for "^
291: (match ret with |`BTYP_void -> "procedure " | _ -> "function ") ^
292: name ^ "\n"
293: );
294: gen_offset_data s n name offsets true props None last_ptr_map
295:
296: let gen_class_offsets s syms (child_map,bbdfns) index vs ts instance last_ptr_map : unit =
297: let vars = (find_references syms (child_map,bbdfns) index ts) in
298: let vars = filter (fun (i, _) -> is_instantiated syms i ts) vars in
299: let varmap = mk_varmap vs ts in
300: let name = cpp_instance_name syms bbdfns index ts in
301: let display = Flx_display.get_display_list syms bbdfns index in
302: let offsets =
303: map
304: (fun (didx, vslen) ->
305: let dptr = "ptr" ^ cpp_instance_name syms bbdfns didx (list_prefix ts vslen) in
306: "offsetof("^name^","^dptr^"),"
307: )
308: display
309: @
310: concat
311: (
312: map
313: (fun (idx,typ)->
314: let mem = cpp_instance_name syms bbdfns idx ts in
315: let offsets = get_offsets syms bbdfns typ in
316: map
317: (fun offset ->
318: "offsetof("^name^","^mem^")+" ^ offset
319: )
320: offsets
321: )
322: vars
323: )
324: in
325: bcat s
326: (
327: "\n//OFFSETS for class "^ name ^
328: "<"^si index^">["^catmap "," (sbt syms.dfns) ts^"] = instance "^si instance^"\n" ^
329: "// WARNING, incomplete, not handling ptf yet .. \n"
330: );
331: let n = length offsets in
332: gen_offset_data s n name offsets true [] None last_ptr_map
333:
334: let gen_thread_frame_offsets s syms bbdfns last_ptr_map =
335: let vars = find_thread_vars_with_type bbdfns in
336: let ts = [] in
337: let name = "thread_frame_t" in
338: let offsets =
339: concat
340: (
341: map
342: (fun (idx,typ)->
343: let mem = cpp_instance_name syms bbdfns idx ts in
344: let offsets = get_offsets syms bbdfns typ in
345: map
346: (fun offset ->
347: "offsetof("^name^","^mem^")+" ^ offset
348: )
349: offsets
350: )
351: vars
352: )
353: in
354: let n = length offsets in
355: bcat s
356: (
357: "\n//OFFSETS for "^ name ^ "\n"
358: );
359: gen_offset_data s n name offsets false [] (Some "gc_flags_immobile") last_ptr_map
360:
361: let id x = ()
362:
363: let scan_bexpr syms allocable_types e : unit =
364: let rec aux e = match e with
365: | `BEXPR_new ((_,t) as x),_ ->
366: let t = lstrip syms.dfns t in
367: let t = reduce_type t in
368: (*
369: print_endline ("FOUND A NEW " ^ sbt syms.dfns t);
370: *)
371: let index =
372: try Hashtbl.find syms.registry t
373: with Not_found -> failwith ("Can't find type in registry " ^ sbt syms.dfns t)
374: in
375: Hashtbl.replace allocable_types t index;
376:
377: | x -> ()
378: in
379: iter_tbexpr id aux id e
380:
381: let scan_exe syms allocable_types exe : unit =
382: iter_bexe id (scan_bexpr syms allocable_types) id id id exe
383:
384: let scan_exes syms allocable_types exes : unit =
385: iter (scan_exe syms allocable_types) exes
386:
387: let gen_offset_tables syms (child_map,bbdfns) module_name =
388: let allocable_types = Hashtbl.create 97 in
389: let scan exes = scan_exes syms allocable_types exes in
390: let last_ptr_map = ref "NULL" in
391: let primitive_shapes = Hashtbl.create 97 in
392: let s = Buffer.create 20000 in
393:
394: (* print_endline "Function and procedure offsets"; *)
395: Hashtbl.iter
396: (fun (index,ts) instance ->
397: let id,parent,sr,entry =
398: try Hashtbl.find bbdfns index
399: with Not_found -> failwith ("[gen_offset_tables] can't find index " ^ si index)
400: in
401: (*
402: print_endline ("Offsets for " ^ id ^ "<"^ si index ^">["^catmap "," (sbt syms.dfns) ts ^"]");
403: *)
404: match entry with
405: | `BBDCL_function (props,vs,ps, ret,exes) ->
406: scan exes;
407: if mem `Cfun props then () else
408: if mem `Heap_closure props then
409: gen_fun_offsets s syms (child_map,bbdfns) index vs ps ret ts instance props last_ptr_map
410: (*
411: else
412: print_endline ("Warning: no closure of " ^ id ^ "<"^si index ^"> is used")
413: *)
414:
415: | `BBDCL_class (props,vs) ->
416: gen_class_offsets s syms (child_map,bbdfns) index vs ts instance last_ptr_map
417:
418: | `BBDCL_regmatch (props,vs,ps,ret,_)
419: | `BBDCL_reglex (props,vs,ps,_,ret,_) ->
420: if mem `Heap_closure props then
421: gen_fun_offsets s syms (child_map,bbdfns) index vs ps ret ts instance props last_ptr_map
422: (*
423: else
424: print_endline ("Warning: no closure of " ^ id ^ "<"^si index ^"> is used")
425: *)
426:
427: | `BBDCL_procedure (props,vs,ps,exes) ->
428: scan exes;
429: if mem `Cfun props then () else
430: if mem `Heap_closure props then
431: gen_fun_offsets s syms (child_map,bbdfns) index vs ps `BTYP_void ts instance props last_ptr_map
432: else if mem `Stack_closure props then ()
433: else
434: print_endline ("Warning: no closure of " ^ id ^"<" ^ si index ^ "> is used, but not stackable?")
435: | _ -> ()
436: )
437: syms.instances
438: ;
439: gen_thread_frame_offsets s syms bbdfns last_ptr_map
440: ;
441:
442: (* We're not finished: we need offsets dynamically allocated types too *)
443:
444: (* currently the ONLY non-function types that can be allocated
445: are the arguments of non-constant variant constructors:
446: this WILL change when a 'new' operator is introduced.
447: *)
448: Hashtbl.iter
449: (fun btyp index ->
450: match unfold syms.dfns btyp with
451: | `BTYP_sum args ->
452: iter
453: (fun t -> let t = reduce_type t in
454: match t with
455: | `BTYP_tuple []
456: | `BTYP_void -> ()
457: | _ ->
458: try
459: let index = Hashtbl.find syms.registry t in
460: Hashtbl.replace allocable_types t index
461: with Not_found -> ()
462: )
463: args
464:
465: | `BTYP_variant args ->
466: iter
467: (fun (_,t) -> let t = reduce_type t in
468: match t with
469: | `BTYP_tuple []
470: | `BTYP_void -> ()
471: | _ ->
472: try
473: let index = Hashtbl.find syms.registry t in
474: Hashtbl.replace allocable_types t index
475: with Not_found -> ()
476: )
477: args
478:
479: | `BTYP_inst (i,ts) ->
480: (*
481: print_endline ("Thinking about instance type --> " ^ string_of_btypecode syms.dfns btyp);
482: *)
483: let id,parent,sr,entry =
484: try Hashtbl.find bbdfns i
485: with Not_found -> failwith ("[gen_offset_tables:BTYP_inst] can't find index " ^ si i)
486: in
487: begin match entry with
488: | `BBDCL_abs (vs,bquals,_,_) ->
489: (*
490: print_endline ("abstract type "^id^".. quals:");
491: print_endline (string_of_bquals syms.dfns bquals);
492: *)
493: let handle_qual bqual = match bqual with
494: | `Bound_needs_shape t ->
495: (*
496: print_endline ("Needs shape (uninstantiated) " ^ sbt syms.dfns t);
497: *)
498: let varmap = mk_varmap vs ts in
499: let t = varmap_subst varmap t in
500: (*
501: print_endline ("Needs shape (instantiated) " ^ sbt syms.dfns t);
502: *)
503: begin try
504: let index = Hashtbl.find syms.registry t in
505: Hashtbl.replace allocable_types t index
506: with
507: | Not_found -> failwith "[gen_offset_tables] Woops, type isn't in registry?"
508: end
509:
510: | _ -> ()
511: in
512: let rec aux quals = match quals with
513: | [] -> ()
514: | h :: t -> handle_qual h; aux t
515: in aux bquals
516:
517: | `BBDCL_class (props,vs) ->
518: (*
519: print_endline "Detected class instance type";
520: *)
521: begin try
522: let index =
523: try Hashtbl.find syms.registry btyp
524: with Not_found -> failwith ("[gen_offset_tables:BTYP_inst:class] can't find type in registry " ^ sbt syms.dfns btyp)
525: in
526: (*
527: print_endline ("Class " ^id ^"<"^ si i ^ ">, ts=["^
528: catmap "," (fun t -> sbt syms.dfns t) ts
529: ^"] type registry instance " ^ si index);
530: *)
531: Hashtbl.replace allocable_types btyp index
532: with Not_found ->
533: print_endline ("Can't find the type " ^ sbt syms.dfns btyp ^ " in registry");
534: failwith ("Can't find the type " ^ sbt syms.dfns btyp ^ " in registry")
535: end
536:
537: (* this routine assumes any use of a union component is
538: allocable .. this is quite wrong but safe. This SHOULD
539: be drived by detecting constructor expressions
540:
541: We don't need to worry about pattern matches .. if
542: we didn't construct it, perhaps a foreigner did,
543: in which case THEY needed to create the shape object
544: *)
545: | `BBDCL_union (vs,args) ->
546: let varmap = mk_varmap vs ts in
547: let args = map (fun (_,_,t)->t) args in
548: let args = map (varmap_subst varmap) args in
549: iter
550: (fun t -> let t = reduce_type t in
551: match t with
552: | `BTYP_tuple []
553: | `BTYP_void -> ()
554: | _ ->
555: try
556: let index = Hashtbl.find syms.registry t in
557: Hashtbl.replace allocable_types t index
558: with Not_found -> ()
559: )
560: args
561: | _ -> ()
562: end
563: | _ -> ()
564: )
565: syms.registry
566: ;
567: Hashtbl.iter
568: (fun btyp index ->
569: (*
570: print_endline ("allocable type --> " ^ string_of_btypecode syms.dfns btyp);
571: *)
572: match unfold syms.dfns btyp with
573: | `BTYP_function _ -> ()
574:
575: | `BTYP_tuple args ->
576: let name = cpp_type_classname syms btyp in
577: let offsets = get_offsets syms bbdfns btyp in
578: let n = length offsets in
579: let classname = cpp_type_classname syms btyp in
580: bcat s ("\n//OFFSETS for tuple type " ^ si index ^ "\n");
581: gen_offset_data s n name offsets false [] None last_ptr_map
582:
583: (* This is just a _ref_, the offset data is in the system library *)
584: | `BTYP_pointer t -> ()
585:
586: (* for an array, we only have offsets for the first element *)
587: | `BTYP_array (t,i) ->
588: let k =
589: try int_of_unitsum i
590: with Not_found -> failwith "Array index must be unitsum"
591: in
592: let name = cpp_typename syms btyp in
593: let tname = cpp_typename syms t in
594: let offsets = get_offsets syms bbdfns t in
595: let is_pod =
596: match t with
597: | `BTYP_inst (k,ts) ->
598: let id,sr,parent,entry = Hashtbl.find bbdfns k in
599: begin match entry with
600: | `BBDCL_abs (_,quals,_,_) -> mem `Pod quals
601: | _ -> false
602: end
603: | _ -> false
604: in
605: let n = length offsets in
606: bcat s ("\n//OFFSETS for array type " ^ si index ^ "\n");
607: if n <> 0 then begin
608: bcat s ("static std::size_t " ^ name ^ "_offsets["^si n^"]={\n ");
609: bcat s (" " ^ cat ",\n " offsets);
610: bcat s "};\n"
611: end
612: ;
613:
614: let this_ptr_map = name ^ "_ptr_map" in
615: let old_ptr_map = !last_ptr_map in
616: last_ptr_map := "&"^this_ptr_map;
617:
618: if not is_pod then begin
619: bcat s ("static void " ^ name ^ "_finaliser(collector_t *, void *p){\n");
620: bcat s (" (("^ tname ^ "*)p)->~" ^ tname ^ "();\n");
621: bcat s (" p = (void*)((char*)p + sizeof("^tname^"));\n");
622: bcat s ("}\n")
623: end
624: ;
625: bcat s ("static gc_shape_t "^ name ^"_ptr_map(\n");
626: bcat s (" " ^ old_ptr_map ^ ",\n");
627: bcat s (" \"" ^ name ^ "\",\n");
628: bcat s (" " ^ si k ^ ",\n");
629: bcat s (" sizeof("^name^"),\n");
630: bcat s
631: (
632: if not is_pod then (" "^name^"_finaliser,\n")
633: else (" 0,\n")
634: );
635: bcat s
636: (
637: " "^si n^
638: (
639: if n = 0 then ",0\n"
640: else ",\n " ^name^"_offsets\n"
641: )
642: );
643: bcat s ");\n"
644:
645: | `BTYP_inst (i,ts) ->
646: let name = cpp_typename syms btyp in
647: let id,parent,sr,entry =
648: try Hashtbl.find bbdfns i
649: with Not_found -> failwith ("[gen_offset_tables:BTYP_inst:allocable_types] can't find index " ^ si i)
650: in
651: begin match entry with
652: | `BBDCL_class (props,vs) ->
653: let instance = index in
654: (*
655: print_endline ("[gen_offset_tables] CLASS TYPE INSTANCE(skipping). Class " ^ si i ^ " instance " ^ si instance);
656: *)
657: let class_instance =
658: try Hashtbl.find syms.instances (i,ts)
659: with Not_found -> failwith ("WOOPS CAN'T FIND CLASS INSTANCE CORRESONDING TO CLASS TYPE INSTANCE")
660: in
661: bcat s ("\n/* CLASS TYPE "^id^"<"^si i^">["^catmap "," (sbt syms.dfns) ts^"] INSTANCE "^si instance^" OFFSETS WILL GO HERE */\n");
662: bcat s ("/* CLASS TYPE INSTANCE IS CURRENTLY CLASS INSTANCE */\n");
663: bcat s ("/* SEE CLASS "^id^"<"^si i^">["^catmap "," (sbt syms.dfns) ts^"] INSTANCE "^si class_instance^"*/\n")
664: (*
665: gen_class_offsets s syms (child_map,bbdfns) index vs ts instance
666: *)
667:
668: | `BBDCL_abs (_,quals,_,_) ->
669: let complete = not (mem `Incomplete quals) in
670: let pod = mem `Pod quals in
671: if complete then
672: if not (Hashtbl.mem primitive_shapes name) then
673: begin
674: Hashtbl.add primitive_shapes name true;
675: bcat s ("\n//OFFSETS for complete abstract "^(if pod then "pod " else "finalisable ")^
676: "type " ^ name ^ " instance\n"
677: );
678:
679: let this_ptr_map = name ^ "_ptr_map" in
680: let old_ptr_map = !last_ptr_map in
681: last_ptr_map := "&"^this_ptr_map;
682:
683: if not pod then bcat s ("FLX_FINALISER("^name^")\n");
684: bcat s ( "static gc_shape_t " ^ name ^ "_ptr_map(\n") ;
685: bcat s (" " ^ old_ptr_map ^ ",\n");
686: bcat s (" \"" ^ name ^ "\",\n");
687: if pod then
688: bcat s (" 1,sizeof("^name^"),0,0,0\n")
689: else
690: bcat s (" 1,sizeof("^name^"),"^name^"_finaliser,0,0\n")
691: ;
692: bcat s ");\n"
693: end else begin
694: bcat s ("\n//OFFSETS for abstract type " ^ name ^ " instance\n");
695: bcat s ("//Use "^name^"_ptr_map\n");
696: end
697: else
698: clierr sr
699: ("[ogen] attempt to allocate an incomplete type: '" ^ id ^"'")
700:
701: | `BBDCL_union _ -> () (* handled by universal _uctor_ *)
702: | `BBDCL_cstruct (vs,cps) ->
703: (* cstruct shouldn't have allocable stuff in it *)
704:
705: let this_ptr_map = name ^ "_ptr_map" in
706: let old_ptr_map = !last_ptr_map in
707: last_ptr_map := "&"^this_ptr_map;
708:
709: bcat s ("\n//OFFSETS for cstruct type " ^ name ^ " instance\n");
710:
711: (* HACK .. in fact, some C structs might have finalisers! *)
712: let pod = true in
713: if not pod then bcat s ("FLX_FINALISER("^name^")\n");
714: bcat s ( "static gc_shape_t " ^ name ^ "_ptr_map(\n") ;
715: bcat s (" " ^ old_ptr_map ^ ",\n");
716: bcat s (" \"" ^ name ^ "\",\n");
717: if pod then
718: bcat s (" 1,sizeof("^name^"),0,0,0\n")
719: else
720: bcat s (" 1,sizeof("^name^"),"^name^"_finaliser,0,0\n")
721: ;
722: bcat s ");\n"
723:
724: | `BBDCL_struct (vs,cps) ->
725: failwith
726: (
727: "[ogen]: can't handle struct offsets yet: type " ^
728: sbt syms.dfns btyp
729: )
730: (*
731: bcat s ("\n//OFFSETS for struct type " ^ name ^ " instance\n");
732: bcat s ("//CANT HANDLE YET!\n");
733: *)
734: | _ ->
735: failwith
736: (
737: "[ogen]: can't handle instances of this kind yet: type " ^
738: sbt syms.dfns btyp
739: )
740: end
741:
742: | `BTYP_unitsum _ ->
743: let name = cpp_typename syms btyp in
744: bcat s ("static gc_shape_t &"^ name ^"_ptr_map = flx::rtl::_int_ptr_map;\n");
745:
746: | `BTYP_sum _ ->
747: let name = cpp_typename syms btyp in
748: bcat s ("static gc_shape_t &"^ name ^"_ptr_map = flx::rtl::_uctor_ptr_map;\n");
749:
750: | _ ->
751: failwith
752: (
753: "[ogen]: Unknown kind of allocable type " ^
754: sbt syms.dfns btyp
755: )
756: )
757: allocable_types
758: ;
759: bcat s ("\n");
760: bcat s ("// Head of shape list\n");
761: bcat s ("extern \"C\" FLX_EXPORT gc_shape_t *" ^ cid_of_flxid module_name ^ "_head_shape;\n");
762: bcat s ("gc_shape_t *" ^ cid_of_flxid module_name ^ "_head_shape=" ^ !last_ptr_map ^ ";\n");
763: Buffer.contents s
764:
765: