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