5.58. GC shape object generator

Start ocaml section to src/flx_ogen.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_ogen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: 
     7: val gen_offset_tables:
     8:   sym_state_t ->
     9:   (bid_t, bid_t list) Hashtbl.t *
    10:   fully_bound_symbol_table_t ->
    11:   string ->
    12:   string
    13: 
    14: val find_thread_vars_with_type:
    15:   fully_bound_symbol_table_t ->
    16:   (bid_t * btypecode_t) list
    17: 
    18: val find_references:
    19:   sym_state_t ->
    20:   (bid_t, bid_t list) Hashtbl.t *
    21:   fully_bound_symbol_table_t ->
    22:   bid_t ->
    23:   btypecode_t list ->
    24:   (bid_t * btypecode_t) list
    25: 
End ocaml section to src/flx_ogen.mli[1]
Start ocaml section to src/flx_ogen.ml[1 /1 ]
     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: 
End ocaml section to src/flx_ogen.ml[1]