5.50. Reparenting

Start ocaml section to src/flx_reparent.mli[1 /1 ]
     1: # 5 "./lpsrc/flx_reparent.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_call
     7: open Flx_child
     8: 
     9: val vsplice : 'a list -> int -> 'a list -> 'a list
    10: 
    11: val reparent1 :
    12:   sym_state_t ->
    13:   usage_table_t * child_map_t * fully_bound_symbol_table_t ->
    14:   (string, string) Hashtbl.t ->   (* relabel *)
    15:   (int, btypecode_t) Hashtbl.t -> (* varmap *)
    16:   (bid_t, bid_t) Hashtbl.t ->     (* revariable *)
    17:   (string * int) list ->          (* caller vs *)
    18:   int ->                          (* callee vs length *)
    19:   bid_t ->                        (* routine index *)
    20:   int option ->                   (* parent *)
    21:   int ->                          (* new index, perhaps the caller! *)
    22:   bool ->                         (* allow rescan of cloned stuff? *)
    23:   unit
    24: 
    25: val reparent_children :
    26:   sym_state_t ->
    27:   usage_table_t * child_map_t * fully_bound_symbol_table_t ->
    28:   (string * int) list ->           (* caller vs *)
    29:   int ->                           (* callee_vs_len *)
    30:   bid_t ->                         (* routine index *)
    31:   bid_t option ->                  (* parent *)
    32:   (string, string) Hashtbl.t ->    (* relabel *)
    33:   (int, btypecode_t) Hashtbl.t ->  (* varmap *)
    34:   bool ->                          (* rescan flag *)
    35:   (int, bid_t) Hashtbl.t           (* returns revariable map *)
    36: 
    37: val specialise_symbol:
    38:   sym_state_t ->
    39:   usage_table_t * child_map_t * fully_bound_symbol_table_t ->
    40:   (string * int) list ->           (* caller vs *)
    41:   int ->                           (* callee_vs_len *)
    42:   bid_t ->                         (* routine index *)
    43:   btypecode_t list ->              (* instantiating types *)
    44:   bid_t option ->                  (* parent *)
    45:   (string, string) Hashtbl.t ->    (* relabel *)
    46:   (int, btypecode_t) Hashtbl.t ->  (* varmap *)
    47:   bool ->                          (* rescan flag *)
    48:   int * btypecode_t list           (* result instance *)
    49: 
    50: val remap_expr :
    51:   sym_state_t ->
    52:   fully_bound_symbol_table_t ->
    53:   (int, btypecode_t) Hashtbl.t ->
    54:   (bid_t, bid_t) Hashtbl.t ->
    55:   btypecode_t list ->
    56:   int ->
    57:   tbexpr_t ->
    58:   tbexpr_t
    59: 
End ocaml section to src/flx_reparent.mli[1]
Start ocaml section to src/flx_reparent.ml[1 /1 ]
     1: # 65 "./lpsrc/flx_reparent.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_print
     6: open Flx_mtypes1
     7: open Flx_mtypes2
     8: open Flx_typing
     9: open Flx_mbind
    10: open Flx_srcref
    11: open List
    12: open Flx_unify
    13: open Flx_treg
    14: open Flx_generic
    15: open Flx_maps
    16: open Flx_exceptions
    17: open Flx_use
    18: open Flx_child
    19: 
    20: module BidSet = IntSet
    21: 
    22: let mk_remap counter d =
    23:   let m = Hashtbl.create 97 in
    24:   IntSet.iter
    25:   (fun i ->
    26:     let n = !counter in
    27:     incr counter;
    28:     Hashtbl.add m i n
    29:   )
    30:   d
    31:   ;
    32:   m
    33: 
    34: (* replace callee type variables with callers *)
    35: let vsplice caller_vars callee_vs_len ts =
    36:   if not (callee_vs_len <= length ts)
    37:   then failwith
    38:   (
    39:     "Callee_vs_len = " ^
    40:     si callee_vs_len ^
    41:     ", len vs/ts= " ^
    42:     si (length ts) ^
    43:     ", length caller_vars = " ^
    44:     si (length caller_vars)
    45:   )
    46:   ;
    47:   let rec aux lst n =  (* elide first n elements *)
    48:     if n = 0 then lst
    49:     else aux (tl lst) (n-1)
    50:   in
    51:   caller_vars @ aux ts callee_vs_len
    52: 
    53: 
    54: (* varmap is the *typevariable* remapper,
    55:  revariable remaps indices
    56: *)
    57: let ident x = x
    58: 
    59: let remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e =
    60:   (*
    61:   print_endline ("Remapping expression " ^ sbe syms.dfns e);
    62:   *)
    63:   let ftc i ts = Flx_typeclass.maybe_fixup_typeclass_instance syms bbdfns i ts in
    64:   let revar i = try Hashtbl.find revariable i with Not_found -> i in
    65:   let tmap t = match t with
    66:   | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
    67:   | x -> x
    68:   in
    69:   let auxt t =
    70:     map_btype tmap (varmap_subst varmap t)
    71:   in
    72:   let fixup i ts =
    73:     let ts = map auxt ts in
    74:     try
    75:       let j= Hashtbl.find revariable i in
    76:       j, vsplice caller_vars callee_vs_len ts
    77:     with Not_found -> i,ts
    78:   in
    79:   let rec aux e = match map_tbexpr ident aux auxt e with
    80:   | `BEXPR_name (i,ts),t ->
    81:     let i,ts = fixup i ts in
    82:     `BEXPR_name (i,ts), auxt t
    83: 
    84:   | `BEXPR_ref (i,ts) as x,t ->
    85:     let i,ts = fixup i ts in
    86:     `BEXPR_ref (i,ts), auxt t
    87: 
    88:   | `BEXPR_closure (i,ts),t ->
    89:     let i,ts = fixup i ts in
    90:     `BEXPR_closure (i,ts), auxt t
    91: 
    92:   | `BEXPR_method_closure (obj,i,ts),t ->
    93:     let i,ts = fixup i ts in
    94:     `BEXPR_method_closure (aux obj,i,ts), auxt t
    95: 
    96:   | `BEXPR_apply_direct (i,ts,e),t ->
    97:     let i,ts = fixup i ts in
    98: 
    99:     (* attempt to fixup typeclass virtual *)
   100:     let i,ts = ftc i ts in
   101:     `BEXPR_apply_direct (i,ts,aux e), auxt t
   102: 
   103:   | `BEXPR_apply_method_direct (obj,i,ts,e),t ->
   104:     let i,ts = fixup i ts in
   105:     `BEXPR_apply_method_direct (aux obj,i,ts,aux e), auxt t
   106: 
   107:   | `BEXPR_apply_stack (i,ts,e),t ->
   108:     let i,ts = fixup i ts in
   109:     `BEXPR_apply_stack (i,ts,aux e), auxt t
   110: 
   111:   | `BEXPR_apply_method_stack (obj,i,ts,e),t ->
   112:     let i,ts = fixup i ts in
   113:     `BEXPR_apply_method_stack (aux obj,i,ts,aux e), auxt t
   114: 
   115:   | `BEXPR_apply_prim (i,ts,e),t ->
   116:     let i,ts = fixup i ts in
   117:     `BEXPR_apply_prim (i,ts,aux e), auxt t
   118: 
   119:   | `BEXPR_parse (e,gs),t ->
   120:     let e = aux e in
   121:     let gs = map revar gs in
   122:     `BEXPR_parse (e,gs), auxt t
   123: 
   124:   | x -> x
   125:   in
   126:     let a = aux e in
   127:     (*
   128:     print_endline ("replace " ^ sbe syms.dfns e ^ "-->" ^ sbe syms.dfns a);
   129:     *)
   130:     a
   131: 
   132: let remap_exe syms bbdfns relabel varmap revariable caller_vars callee_vs_len exe =
   133:   (*
   134:   print_endline ("remap_exe " ^ string_of_bexe syms.dfns 0 exe);
   135:   *)
   136:   let ge e = remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e in
   137:   let revar i = try Hashtbl.find revariable i with Not_found -> i in
   138:   let relab s = try Hashtbl.find relabel s with Not_found -> s in
   139:   let ftc i ts = Flx_typeclass.maybe_fixup_typeclass_instance syms bbdfns i ts in
   140: 
   141:   let tmap t = match t with
   142:   | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
   143:   | x -> x
   144:   in
   145:   let auxt t =
   146:     map_btype tmap (varmap_subst varmap t)
   147:   in
   148:   let exe =
   149:   match exe with
   150:   | `BEXE_axiom_check _ -> assert false
   151:   | `BEXE_call_prim (sr,i,ts,e2)  ->  assert false
   152:     (*
   153:     let fixup i ts =
   154:       let ts = map auxt ts in
   155:       try
   156:         let j= Hashtbl.find revariable i in
   157:         j, vsplice caller_vars callee_vs_len ts
   158:       with Not_found -> i,ts
   159:     in
   160:     let i,ts = fixup i ts in
   161:     `BEXE_call_prim (sr,i,ts, ge e2)
   162:     *)
   163: 
   164:   | `BEXE_call_direct (sr,i,ts,e2)  ->  assert false
   165:     (*
   166:     let fixup i ts =
   167:       let ts = map auxt ts in
   168:       try
   169:         let j= Hashtbl.find revariable i in
   170:         j, vsplice caller_vars callee_vs_len ts
   171:       with Not_found -> i,ts
   172:     in
   173:     let i,ts = fixup i ts in
   174: 
   175:     (* attempt to instantiate typeclass virtual *)
   176:     let i,ts = ftc i ts in
   177:     `BEXE_call_direct (sr,i,ts, ge e2)
   178:     *)
   179: 
   180:   | `BEXE_call_method_direct (sr,e1,i,ts,e2)  ->
   181:     let fixup i ts =
   182:       let ts = map auxt ts in
   183:       try
   184:         let j= Hashtbl.find revariable i in
   185:         j, vsplice caller_vars callee_vs_len ts
   186:       with Not_found -> i,ts
   187:     in
   188:     let i,ts = fixup i ts in
   189:     `BEXE_call_method_direct (sr,ge e1,i,ts, ge e2)
   190: 
   191:   | `BEXE_call_method_stack (sr,e1,i,ts,e2)  ->
   192:     let fixup i ts =
   193:       let ts = map auxt ts in
   194:       try
   195:         let j= Hashtbl.find revariable i in
   196:         j, vsplice caller_vars callee_vs_len ts
   197:       with Not_found -> i,ts
   198:     in
   199:     let i,ts = fixup i ts in
   200:     `BEXE_call_method_stack (sr,ge e1,i,ts, ge e2)
   201: 
   202:   | `BEXE_call_stack (sr,i,ts,e2)  ->  assert false
   203:     (*
   204:     let fixup i ts =
   205:       let ts = map auxt ts in
   206:       try
   207:         let j= Hashtbl.find revariable i in
   208:         j, vsplice caller_vars callee_vs_len ts
   209:       with Not_found -> i,ts
   210:     in
   211:     let i,ts = fixup i ts in
   212:     `BEXE_call_stack (sr,i,ts, ge e2)
   213:     *)
   214: 
   215:   (*
   216:   | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2) ->
   217:     print_endline ("Apply ctor " ^ si i1 ^ ", " ^ si i2 ^ ", [" ^
   218:     catmap "," (sbt syms.dfns) ts ^ "]" ^ si i3);
   219:     let fixup i ts =
   220:       let ts = map auxt ts in
   221:       try
   222:         let j= Hashtbl.find revariable i in
   223:         j, vsplice caller_vars callee_vs_len ts
   224:       with Not_found -> i,ts
   225:     in
   226:     let i2,ts = fixup i2 ts in
   227:     `BEXE_apply_ctor (sr,revar i1,i2,ts,revar i3,ge e2)
   228: 
   229:   | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2) ->
   230:     print_endline ("Apply ctor stack " ^ si i1 ^ ", " ^ si i2 ^ ", [" ^
   231:     catmap "," (sbt syms.dfns) ts ^ "]" ^ si i3);
   232:     let fixup i ts =
   233:       let ts = map auxt ts in
   234:       try
   235:         let j= Hashtbl.find revariable i in
   236:         j, vsplice caller_vars callee_vs_len ts
   237:       with Not_found -> i,ts
   238:     in
   239:     let i2,ts = fixup i2 ts in
   240:     `BEXE_apply_ctor_stack (sr,revar i1,i2,ts,revar i3,ge e2)
   241:   *)
   242: 
   243:   | x -> map_bexe revar ge ident relab relab x
   244:   in
   245:   (*
   246:   print_endline ("remapped_exe " ^ string_of_bexe syms.dfns 0 exe);
   247:   *)
   248:   exe
   249: 
   250: 
   251: let remap_exes syms bbdfns relabel varmap revariable caller_vars callee_vs_len exes =
   252:   map (remap_exe syms bbdfns relabel varmap revariable caller_vars callee_vs_len) exes
   253: 
   254: let remap_reqs syms bbdfns varmap revariable caller_vars callee_vs_len reqs : breqs_t =
   255:   let revar i = try Hashtbl.find revariable i with Not_found -> i in
   256:   let tmap t = match t with
   257:   | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
   258:   | x -> x
   259:   in
   260:   let auxt t =
   261:     map_btype tmap (varmap_subst varmap t)
   262:   in
   263:   let fixup (i, ts) =
   264:     let ts = map auxt ts in
   265:     try
   266:       let j= Hashtbl.find revariable i in
   267:       j, vsplice caller_vars callee_vs_len ts
   268:     with Not_found -> i,ts
   269:   in
   270:   map fixup reqs
   271: 
   272: 
   273: (* this routine makes a (type) specialised version of a symbol:
   274:    a function, procedure, variable, or whatever.
   275: 
   276:    relabel: maps old labels onto fresh labels
   277:    revariable: maps old variables and functions to fresh ones
   278:    varmap: maps type variables to types (type specialisation)
   279:    index: this routine
   280:    parent: the new parent
   281: 
   282:    this routine doesn't specialise any children,
   283:    just any reference to them: the kids need
   284:    to be specialised by reparent_children.
   285: *)
   286: 
   287: let allow_rescan flag props =
   288:   match flag with
   289:   | false -> props
   290:   | true -> filter (function | `Inlining_complete | `Inlining_started -> false | _ -> true ) props
   291: 
   292: let reparent1 (syms:sym_state_t) (uses,child_map,bbdfns )
   293:   relabel varmap revariable
   294:   caller_vs callee_vs_len index parent k rescan_flag
   295: =
   296:   let splice vs = (* replace callee type variables with callers *)
   297:     vsplice caller_vs callee_vs_len vs
   298:   in
   299:   let sop = function
   300:     | None -> "NONE?"
   301:     | Some i -> si i
   302:   in
   303:   let caller_vars = map (fun (s,i) -> `BTYP_var (i,`BTYP_type 0)) caller_vs in
   304: 
   305:   let revar i = try Hashtbl.find revariable i with Not_found -> i in
   306:   let tmap t = match t with
   307:   | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
   308:   | x -> x
   309:   in
   310:   let auxt t =
   311:     map_btype tmap (varmap_subst varmap t)
   312:   in
   313:   let remap_ps ps = map (fun {pid=id; pindex=i; ptyp=t; pkind=k} ->
   314:     {pid=id; pindex=revar i; ptyp=auxt t; pkind=k})
   315:      ps
   316:    in
   317: 
   318:   let rexes xs = remap_exes syms bbdfns relabel varmap revariable caller_vars callee_vs_len xs in
   319:   let rexpr e = remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e in
   320:   let rreqs rqs = remap_reqs syms bbdfns varmap revariable caller_vars callee_vs_len rqs in
   321:   let id,old_parent,sr,entry = Hashtbl.find bbdfns index in
   322:   (*
   323:   print_endline
   324:   (
   325:     "COPYING " ^ id ^ " index " ^ si index ^ " with old parent " ^
   326:     sop old_parent ^ " to index " ^ si k ^ " with new parent " ^
   327:     sop parent
   328:   );
   329:   *)
   330:   begin match parent with
   331:   | Some p ->
   332:     let old_kids = try Hashtbl.find child_map p with Not_found -> [] in
   333:     (*
   334:     print_endline ("ADDING " ^ si k ^ " as child of " ^ si p);
   335:     *)
   336:     Hashtbl.replace child_map p (k::old_kids)
   337:   | None -> ()
   338:   end
   339:   ;
   340:   match entry with
   341:   | `BBDCL_procedure (props,vs,(ps,traint),exes) ->
   342:     let exes = rexes exes in
   343:     let ps = remap_ps ps in
   344:     let props = allow_rescan rescan_flag props in
   345:     let props = filter (fun p -> p <> `Virtual) props in
   346:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_procedure (props,splice vs,(ps,traint),exes));
   347:     (*
   348:     print_endline "NEW PROCEDURE (clone):";
   349:     print_function syms.dfns bbdfns k;
   350:     *)
   351:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   352:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   353:     (*
   354:     print_endline ("Cal new usage of proc " ^ si k ^ ": " ^
   355:       catmap "," (fun (j,_) -> si j) calls);
   356:     *)
   357:     Hashtbl.add uses k calls
   358: 
   359:   | `BBDCL_function (props, vs, (ps,traint), ret, exes) ->
   360:     let props = allow_rescan rescan_flag props in
   361:     let props = filter (fun p -> p <> `Virtual) props in
   362:     let ps = remap_ps ps in
   363:     let exes = rexes exes in
   364:     let ret = auxt ret in
   365:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_function (props,splice vs,(ps,traint),ret,exes));
   366:     (*
   367:     print_endline "NEW FUNCTION (clone):";
   368:     print_function syms.dfns bbdfns k;
   369:     *)
   370:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   371:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   372:     (*
   373:     print_endline ("Cal new usage of fun " ^ si k ^ ": " ^
   374:       catmap "," (fun (j,_) -> si j) calls);
   375:     *)
   376:     Hashtbl.add uses k calls
   377: 
   378:   | `BBDCL_var (vs,t) ->
   379:     (*
   380:     print_endline ("Reparent variable old: id<"^si index^"> vs=" ^
   381:       catmap "," (fun (s,i) -> s^"<"^si i^">") vs);
   382:     print_endline ("         variable new: id<"^si k^"> vs=" ^
   383:       catmap "," (fun (s,i) -> s^"<"^si i^">") (splice vs));
   384:     *)
   385:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_var (splice vs,auxt t))
   386: 
   387:   | `BBDCL_val (vs,t) ->
   388:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_val (splice vs,auxt t))
   389: 
   390:   | `BBDCL_ref (vs,t) ->
   391:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_ref (splice vs,auxt t))
   392: 
   393:   | `BBDCL_tmp (vs,t) ->
   394:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_tmp (splice vs,auxt t))
   395: 
   396:   | `BBDCL_reglex (props,vs,(ps,traint),i,t,(a,j,h,m)) ->
   397:     let t = auxt t in
   398:     let ps = remap_ps ps in
   399:     let vs = splice vs in
   400:     let i = revar i in
   401:     let h2 = Hashtbl.create 13 in
   402:     Hashtbl.iter (fun x e -> Hashtbl.add h2 x (rexpr e)) h;
   403:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_reglex (props,vs,(ps,traint),i,t,(a,j,h2,m)));
   404:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   405:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   406:     Hashtbl.add uses k calls
   407: 
   408: 
   409:   | `BBDCL_regmatch (props,vs,(ps,traint),t,(a,j,h,m)) ->
   410:     let t = auxt t in
   411:     let ps = remap_ps ps in
   412:     let vs = splice vs in
   413:     let h2 = Hashtbl.create 13 in
   414:     Hashtbl.iter (fun x e -> Hashtbl.add h2 x (rexpr e)) h;
   415:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_regmatch (props,vs,(ps,traint),t,(a,j,h2,m)));
   416:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   417:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   418:     Hashtbl.add uses k calls
   419: 
   420: 
   421:   | `BBDCL_glr (props,vs,t,(prd,exes)) ->
   422:     let t = auxt t in
   423:     let vs = splice vs in
   424:     let exes = rexes exes in
   425:     let remap_glr g = match g with
   426:       | `Nonterm js -> `Nonterm (map revar js)
   427:       | x -> x (* terminal codes are invariant *)
   428:     in
   429:     let prd = map (fun (s,g) -> s,remap_glr g) prd in
   430:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_glr (props,vs,t,(prd,exes)));
   431:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   432:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   433:     Hashtbl.add uses k calls
   434: 
   435:   | `BBDCL_class (props,vs) ->
   436:     let vs = splice vs in
   437:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_class (props,vs));
   438:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   439:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   440:     Hashtbl.add uses k calls
   441: 
   442: 
   443:   | `BBDCL_abs (vs,quals,ct,breqs) ->
   444:     let vs = splice vs in
   445:     let breqs = rreqs breqs in
   446:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_abs (vs,quals,ct,breqs));
   447:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   448:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   449:     Hashtbl.add uses k calls
   450: 
   451: 
   452:   | `BBDCL_const (vs,t,ct,breqs) ->
   453:     let vs = splice vs in
   454:     let breqs = rreqs breqs in
   455:     let t = auxt t in
   456:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_const (vs,t,ct,breqs));
   457:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   458:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   459:     Hashtbl.add uses k calls
   460: 
   461: 
   462:   | `BBDCL_proc (props,vs,params,ct,breqs) ->
   463:     let props = filter (fun p -> p <> `Virtual) props in
   464:     let params = map auxt params in
   465:     let vs = splice vs in
   466:     let breqs = rreqs breqs in
   467:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_proc (props,vs,params,ct,breqs));
   468:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   469:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   470:     (*
   471:     print_endline ("Cal new usage of proc " ^ si k ^ ": " ^
   472:       catmap "," (fun (j,_) -> si j) calls);
   473:     *)
   474:     Hashtbl.add uses k calls
   475: 
   476:   | `BBDCL_fun (props,vs,params,ret,ct,breqs,prec) ->
   477:     let props = filter (fun p -> p <> `Virtual) props in
   478:     let params = map auxt params in
   479:     let vs = splice vs in
   480:     let ret = auxt ret in
   481:     let breqs = rreqs breqs in
   482:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_fun (props,vs,params,ret,ct,breqs,prec));
   483:     (*
   484:     print_endline "NEW FUNCTION (clone):";
   485:     print_function syms.dfns bbdfns k;
   486:     *)
   487:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   488:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   489:     (*
   490:     print_endline ("Cal new usage of fun " ^ si k ^ ": " ^
   491:       catmap "," (fun (j,_) -> si j) calls);
   492:     *)
   493:     Hashtbl.add uses k calls
   494: 
   495:   | `BBDCL_insert (vs,ct,ik,breqs) ->
   496:     let breqs = rreqs breqs in
   497:     let vs = splice vs in
   498:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_insert (vs,ct,ik,breqs));
   499:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   500:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   501:     Hashtbl.add uses k calls
   502: 
   503:   (*
   504:   |  _ ->
   505:     Hashtbl.add bbdfns k (id,parent,sr,entry)
   506:   *)
   507: 
   508:   | _ -> syserr sr ("[reparent1] Unexpected: bbdcl " ^ string_of_bbdcl syms.dfns entry index)
   509: 
   510: (* make a copy all the descendants of i, changing any
   511:   parent which is i to the given new parent
   512: *)
   513: 
   514: (* this routine reparents all the children of a given
   515:    routine, but it doesn't reparent the routine itself
   516: *)
   517: 
   518: let reparent_children syms (uses,child_map,bbdfns)
   519:   caller_vs callee_vs_len index parent relabel varmap rescan_flag
   520: =
   521:   let pp p = match p with None -> "NONE" | Some i -> si i in
   522:   (*
   523:   print_endline
   524:   (
   525:     "Renesting children of callee " ^ si index ^
   526:     " to caller " ^ pp parent ^
   527:      "\n  -- Caller vs len = " ^ si (length caller_vs) ^
   528:      "\n  -- Callee vs len = " ^ si (callee_vs_len)
   529:   );
   530:   *)
   531:   let closure = descendants child_map index in
   532:   assert (not (IntSet.mem index closure));
   533:   (*
   534:   let cl = ref [] in IntSet.iter (fun i -> cl := i :: !cl) closure;
   535:   print_endline ("Closure is " ^ catmap " " si !cl);
   536:   *)
   537:   let revariable = mk_remap syms.counter closure in
   538:   IntSet.iter
   539:   (fun i ->
   540:     let old_parent =
   541:       match Hashtbl.find bbdfns i with id,oldp,_,_ -> oldp
   542:     in
   543:     let new_parent: bid_t option =
   544:       match old_parent with
   545:       | None -> assert false
   546:       | Some p ->
   547:         if p = index then parent
   548:         else Some (Hashtbl.find revariable p)
   549:     in
   550:     let k = Hashtbl.find revariable i in
   551:     reparent1 syms (uses,child_map,bbdfns) relabel varmap revariable
   552:     caller_vs callee_vs_len i new_parent k rescan_flag
   553:   )
   554:   closure
   555:   ;
   556:   if syms.compiler_options.print_flag then begin
   557:     Hashtbl.iter
   558:     (fun i j ->
   559:       print_endline ("//Reparent " ^ si j ^ " <-- " ^ si i)
   560:     )
   561:     revariable
   562:   end
   563:   ;
   564:   revariable
   565: 
   566: (* NOTE! when we specialise a routine, calls to the same
   567:   routine (polymorphically recursive) need not end up
   568:   recursive. They're only recursive if they call the
   569:   original routine with the same type specialisations
   570:   as the one we're making here.
   571: 
   572:   In particular a call is recursive if, and only if,
   573:   it is fully polymorphic (that is, just resupplies
   574:   all the original type variables). In that case,
   575:   recursion is preserved by specialisation.
   576: 
   577:   However recursion can also be *introduced* by specialisation
   578:   where it didn't exist before!
   579: 
   580:   So remapping function indices has to be conditional.
   581: 
   582:   Note that calls to children HAVE to be remapped
   583:   because of reparenting -- the original kids
   584:   are no longer reachable! But this is no problem
   585:   because the kid's inherited type variables are
   586:   specialised away: you can't supply a kid with
   587:   type variable instances distinct from the kid's
   588:   parents variables (or the kid would refer to the
   589:   stack from of a distinct function!)
   590: 
   591:   So the only problem is on self calls of the main
   592:   routine, since they can call self either with
   593:   the current specialisation or any other.
   594: *)
   595: 
   596: 
   597: let specialise_symbol syms (uses,child_map,bbdfns)
   598:   caller_vs callee_vs_len index ts parent relabel varmap rescan_flag
   599: =
   600:   try Hashtbl.find syms.transient_specialisation_cache (index,ts)
   601:   with Not_found ->
   602:     let k = !(syms.counter) in incr (syms.counter);
   603:     let revariable =
   604:        reparent_children syms (uses,child_map,bbdfns)
   605:        caller_vs callee_vs_len index (Some k) relabel varmap rescan_flag
   606:     in
   607:     reparent1 (syms:sym_state_t) (uses,child_map,bbdfns )
   608:       relabel varmap revariable
   609:       caller_vs callee_vs_len index parent k rescan_flag
   610:     ;
   611:     let caller_vars = map (fun (s,i) -> `BTYP_var (i,`BTYP_type 0)) caller_vs in
   612:     let ts' = vsplice caller_vars callee_vs_len ts in
   613:     Hashtbl.add syms.transient_specialisation_cache (index,ts) (k,ts');
   614:     k,ts'
   615: 
End ocaml section to src/flx_reparent.ml[1]