5.66. GC shape object generator

Start ocaml section to src/flx_ogen.mli[1 /1 ]
     1: # 5 "./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: # 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: 
End ocaml section to src/flx_ogen.ml[1]