5.46. Inlining

To make this work, we need a theorem. First, the call rule is:
A procedure may only call a child of an ancestor.
Note an ancestor is itself or a parent of any ancestor: that is, a procedure is an ancestor of itself. A parentless toplevel procedure is considered a child of a dummy root to make this simple formulation work.

It is clear we can inline any sibling by copying its body, and duplicating any children -- variables and nested procedures included. This is because any references to its parent will go through from the caller, since they have the same parent.

Clearly this result extends to any child of any parent.

Start ocaml section to src/flx_inline.mli[1 /1 ]
     1: # 27 "./lpsrc/flx_inline.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_call
     7: 
     8: val heavy_inlining:
     9:   sym_state_t ->
    10:   (bid_t, bid_t list) Hashtbl.t *
    11:   fully_bound_symbol_table_t ->
    12:   unit
    13: 
End ocaml section to src/flx_inline.mli[1]
Start ocaml section to src/flx_inline.ml[1 /1 ]
     1: # 41 "./lpsrc/flx_inline.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 intset_of_list ls =
    23:   fold_left (fun s i -> IntSet.add i s) IntSet.empty ls
    24: 
    25: (* this only updates the uses table not the usedby table,
    26:   because inlining changes usage (obviously).
    27:   we need it in particular for the is_recursive test,
    28:   so that tail recursions which have been eliminated
    29:   won't cause the test to return a false positive
    30: *)
    31: 
    32: let string_of_intset s =
    33:   "{ " ^
    34:   IntSet.fold (fun i x -> x ^ si i ^ " ") s "" ^
    35:   "}"
    36: 
    37: let recal_exes_usage syms uses sr i ps exes =
    38:   (*
    39:   print_endline ("Recal usage of "^ si i^", this code:\n" ^ catmap "\n" (sbx syms.dfns) exes);
    40:   *)
    41:   (* delete old entry *)
    42:   (try Hashtbl.remove uses i with Not_found -> ());
    43:   iter (Flx_call.cal_param_usage syms uses sr i) ps;
    44:   iter (Flx_call.cal_exe_usage syms uses i) exes
    45: 
    46: let is_tailed ps exes =
    47:   try iter
    48:   (function
    49:     | `BEXE_init(_,i,_) when mem i ps -> raise Not_found
    50:     | _ -> ()
    51:   )
    52:   exes;
    53:   false
    54:   with Not_found -> true
    55: 
    56: let string_of_vs vs =
    57:   "[" ^ catmap "," (fun (s,i)->s^"<"^si i^">") vs ^ "]"
    58: 
    59: let useset uses i =
    60:   let u = try Hashtbl.find uses i with Not_found -> [] in
    61:   fold_left (fun s (i,_) -> IntSet.add i s) IntSet.empty u
    62: 
    63: (* find all the variables of a function i which
    64:    are not used by children, this is the kids
    65:    minus just the union of everything used by the
    66:    child functions.
    67: *)
    68: let locals child_map uses i =
    69:   let kids = intset_of_list (find_children child_map i) in
    70:   (*
    71:   print_endline ("Kid of " ^ si i ^ " = " ^ string_of_intset kids);
    72:   *)
    73:   (*
    74:   let u = useset uses i in
    75:   *)
    76:   let u = Flx_call.child_use_closure kids uses i in
    77:   let unused_kids = IntSet.diff kids u in
    78:   (*
    79:   print_endline ("Unused kids are " ^ si i ^ " = " ^ string_of_intset unused_kids);
    80:   *)
    81:   let used_kids = IntSet.diff kids unused_kids in
    82:   (*
    83:   print_endline ("Used kids are " ^ si i ^ " = " ^ string_of_intset used_kids);
    84:   *)
    85:   (*
    86:   let desc = descendants child_map i in
    87:   *)
    88:   let desc =
    89:     IntSet.fold
    90:     (fun j s -> let u = descendants child_map j in IntSet.union u s)
    91:     used_kids
    92:     IntSet.empty
    93:   in
    94:   (*
    95:   print_endline ("Descendants of " ^ si i ^ " = " ^ string_of_intset desc);
    96:   *)
    97:   let u =
    98:     IntSet.fold
    99:     (fun j s ->
   100:       let u = useset uses j in
   101:       (*
   102:       print_endline ("Descendant " ^ si j ^ " of " ^ si i ^ " uses " ^ string_of_intset u);
   103:       *)
   104:       IntSet.union s u
   105:     )
   106:     desc
   107:     IntSet.empty
   108:   in
   109:   (*
   110:   print_endline ("Stuff used by some descendant = " ^ string_of_intset u);
   111:   *)
   112:   IntSet.diff kids u
   113: 
   114: (* remove all uses of j from i *)
   115: let remove_uses uses i j =
   116:   (*
   117:   print_endline "Eliding " ^ si i ^ " from " ^ si j);
   118:   *)
   119:   try
   120:     let u = Hashtbl.find uses i in
   121:     let u = filter (fun (k,sr) -> j <> k) u in
   122:     Hashtbl.replace uses i u
   123:   with Not_found -> ()
   124: 
   125: let add_use uses i j sr =
   126:   let u = try Hashtbl.find uses i with Not_found -> [] in
   127:   Hashtbl.replace uses i ((j,sr) :: u)
   128: 
   129: let mk_remap counter d =
   130:   let m = Hashtbl.create 97 in
   131:   IntSet.iter
   132:   (fun i ->
   133:     let n = !counter in
   134:     incr counter;
   135:     Hashtbl.add m i n
   136:   )
   137:   d
   138:   ;
   139:   m
   140: 
   141: (* replace callee type variables with callers *)
   142: let vsplice caller_vars callee_vs_len ts =
   143:   if not (callee_vs_len <= length ts)
   144:   then failwith
   145:   (
   146:     "Callee_vs_len = " ^
   147:     si callee_vs_len ^
   148:     ", len vs/ts= " ^
   149:     si (length ts) ^
   150:     ", length caller_vars = " ^
   151:     si (length caller_vars)
   152:   )
   153:   ;
   154:   let rec aux lst n =  (* elide first n elements *)
   155:     if n = 0 then lst
   156:     else aux (tl lst) (n-1)
   157:   in
   158:   caller_vars @ aux ts callee_vs_len
   159: 
   160: 
   161: (* varmap is the *typevariable* remapper,
   162:  revariable remaps indices
   163: *)
   164: let ident x = x
   165: 
   166: let remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e =
   167:   (*
   168:   print_endline ("Remapping expression " ^ sbe syms.dfns e);
   169:   *)
   170:   let revar i = try Hashtbl.find revariable i with Not_found -> i in
   171:   let tmap t = match t with
   172:   | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
   173:   | x -> x
   174:   in
   175:   let auxt t =
   176:     map_btype tmap (varmap_subst varmap t)
   177:   in
   178:   let fixup i ts =
   179:     let ts = map auxt ts in
   180:     try
   181:       let j= Hashtbl.find revariable i in
   182:       j, vsplice caller_vars callee_vs_len ts
   183:     with Not_found -> i,ts
   184:   in
   185:   let rec aux e = match map_tbexpr ident aux auxt e with
   186:   | `BEXPR_name (i,ts),t ->
   187:     let i,ts = fixup i ts in
   188:     `BEXPR_name (i,ts), auxt t
   189: 
   190:   | `BEXPR_ref (i,ts) as x,t ->
   191:     let i,ts = fixup i ts in
   192:     `BEXPR_ref (i,ts), auxt t
   193: 
   194:   | `BEXPR_closure (i,ts),t ->
   195:     let i,ts = fixup i ts in
   196:     `BEXPR_closure (i,ts), auxt t
   197: 
   198:   | `BEXPR_method_closure (obj,i,ts),t ->
   199:     let i,ts = fixup i ts in
   200:     `BEXPR_method_closure (aux obj,i,ts), auxt t
   201: 
   202:   | `BEXPR_apply_direct (i,ts,e),t ->
   203:     let i,ts = fixup i ts in
   204:     `BEXPR_apply_direct (i,ts,aux e), auxt t
   205: 
   206:   | `BEXPR_apply_method_direct (obj,i,ts,e),t ->
   207:     let i,ts = fixup i ts in
   208:     `BEXPR_apply_method_direct (aux obj,i,ts,aux e), auxt t
   209: 
   210:   | `BEXPR_apply_stack (i,ts,e),t ->
   211:     let i,ts = fixup i ts in
   212:     `BEXPR_apply_stack (i,ts,aux e), auxt t
   213: 
   214:   | `BEXPR_apply_method_stack (obj,i,ts,e),t ->
   215:     let i,ts = fixup i ts in
   216:     `BEXPR_apply_method_stack (aux obj,i,ts,aux e), auxt t
   217: 
   218:   | `BEXPR_apply_prim (i,ts,e),t ->
   219:     let i,ts = fixup i ts in
   220:     `BEXPR_apply_prim (i,ts,aux e), auxt t
   221: 
   222:   | `BEXPR_parse (e,gs),t ->
   223:     let e = aux e in
   224:     let gs = map revar gs in
   225:     `BEXPR_parse (e,gs), auxt t
   226: 
   227:   | x -> x
   228:   in
   229:     let a = aux e in
   230:     (*
   231:     print_endline ("replace " ^ sbe syms.dfns e ^ "-->" ^ sbe syms.dfns a);
   232:     *)
   233:     a
   234: 
   235: let remap_exe syms bbdfns relabel varmap revariable caller_vars callee_vs_len exe =
   236:   (*
   237:   print_endline ("remap_exe " ^ string_of_bexe syms.dfns 0 exe);
   238:   *)
   239:   let ge e = remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e in
   240:   let revar i = try Hashtbl.find revariable i with Not_found -> i in
   241:   let relab s = try Hashtbl.find relabel s with Not_found -> s in
   242:   let tmap t = match t with
   243:   | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
   244:   | x -> x
   245:   in
   246:   let auxt t =
   247:     map_btype tmap (varmap_subst varmap t)
   248:   in
   249:   let exe =
   250:   match exe with
   251:   | `BEXE_axiom_check _ -> assert false
   252:   | `BEXE_call_prim (sr,i,ts,e2)  ->
   253:     let fixup i ts =
   254:       let ts = map auxt ts in
   255:       try
   256:         let j= Hashtbl.find revariable i in
   257:         j, vsplice caller_vars callee_vs_len ts
   258:       with Not_found -> i,ts
   259:     in
   260:     let i,ts = fixup i ts in
   261:     `BEXE_call_prim (sr,i,ts, ge e2)
   262: 
   263:   | `BEXE_call_direct (sr,i,ts,e2)  ->
   264:     let fixup i ts =
   265:       let ts = map auxt ts in
   266:       try
   267:         let j= Hashtbl.find revariable i in
   268:         j, vsplice caller_vars callee_vs_len ts
   269:       with Not_found -> i,ts
   270:     in
   271:     let i,ts = fixup i ts in
   272:     `BEXE_call_direct (sr,i,ts, ge e2)
   273: 
   274:   | `BEXE_call_method_direct (sr,e1,i,ts,e2)  ->
   275:     let fixup i ts =
   276:       let ts = map auxt ts in
   277:       try
   278:         let j= Hashtbl.find revariable i in
   279:         j, vsplice caller_vars callee_vs_len ts
   280:       with Not_found -> i,ts
   281:     in
   282:     let i,ts = fixup i ts in
   283:     `BEXE_call_method_direct (sr,ge e1,i,ts, ge e2)
   284: 
   285:   | `BEXE_call_method_stack (sr,e1,i,ts,e2)  ->
   286:     let fixup i ts =
   287:       let ts = map auxt ts in
   288:       try
   289:         let j= Hashtbl.find revariable i in
   290:         j, vsplice caller_vars callee_vs_len ts
   291:       with Not_found -> i,ts
   292:     in
   293:     let i,ts = fixup i ts in
   294:     `BEXE_call_method_stack (sr,ge e1,i,ts, ge e2)
   295: 
   296:   | `BEXE_call_stack (sr,i,ts,e2)  ->
   297:     let fixup i ts =
   298:       let ts = map auxt ts in
   299:       try
   300:         let j= Hashtbl.find revariable i in
   301:         j, vsplice caller_vars callee_vs_len ts
   302:       with Not_found -> i,ts
   303:     in
   304:     let i,ts = fixup i ts in
   305:     `BEXE_call_stack (sr,i,ts, ge e2)
   306: 
   307:   | x -> map_bexe revar ge ident relab relab x
   308:   in
   309:   (*
   310:   print_endline ("remapped_exe " ^ string_of_bexe syms.dfns 0 exe);
   311:   *)
   312:   exe
   313: 
   314: 
   315: let remap_exes syms bbdfns relabel varmap revariable caller_vars callee_vs_len exes =
   316:   map (remap_exe syms bbdfns relabel varmap revariable caller_vars callee_vs_len) exes
   317: 
   318: let reparent1 (syms:sym_state_t) (uses,child_map,bbdfns )
   319:   relabel varmap revariable
   320:   caller_vs callee_vs_len index parent
   321: =
   322:   let splice vs = (* replace callee type variables with callers *)
   323:     vsplice caller_vs callee_vs_len vs
   324:   in
   325:   let sop = function
   326:     | None -> "NONE?"
   327:     | Some i -> si i
   328:   in
   329:   let caller_vars = map (fun (s,i) -> `BTYP_var (i,`BTYP_type)) caller_vs in
   330: 
   331:   let revar i = try Hashtbl.find revariable i with Not_found -> i in
   332:   let tmap t = match t with
   333:   | `BTYP_inst (i,ts) -> `BTYP_inst (revar i,ts)
   334:   | x -> x
   335:   in
   336:   let auxt t =
   337:     map_btype tmap (varmap_subst varmap t)
   338:   in
   339:   let remap_ps ps = map (fun (id,(i,t)) -> id,(revar i,auxt t)) ps in
   340: 
   341:   let k = Hashtbl.find revariable index in
   342:   let rexes xs = remap_exes syms bbdfns relabel varmap revariable caller_vars callee_vs_len xs in
   343:   let rexpr e = remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e in
   344:   let id,old_parent,sr,entry = Hashtbl.find bbdfns index in
   345:   (*
   346:   print_endline
   347:   (
   348:     "COPYING " ^ id ^ " index " ^ si index ^ " with old parent " ^
   349:     sop old_parent ^ " to index " ^ si k ^ " with new parent " ^
   350:     sop parent
   351:   );
   352:   *)
   353:   begin match parent with
   354:   | Some p ->
   355:     let old_kids = try Hashtbl.find child_map p with Not_found -> [] in
   356:     (*
   357:     print_endline ("ADDING " ^ si k ^ " as child of " ^ si p);
   358:     *)
   359:     Hashtbl.replace child_map p (k::old_kids)
   360:   | None -> ()
   361:   end
   362:   ;
   363:   match entry with
   364:   | `BBDCL_procedure (props,vs,(ps,traint),exes) ->
   365:     let exes = rexes exes in
   366:     let ps = remap_ps ps in
   367:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_procedure (props,splice vs,(ps,traint),exes));
   368:     (*
   369:     print_endline "NEW PROCEDURE (clone):";
   370:     print_function syms.dfns bbdfns k;
   371:     *)
   372:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   373:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   374:     (*
   375:     print_endline ("Cal new usage of proc " ^ si k ^ ": " ^
   376:       catmap "," (fun (j,_) -> si j) calls);
   377:     *)
   378:     Hashtbl.add uses k calls
   379: 
   380:   | `BBDCL_function (props, vs, (ps,traint), ret, exes) ->
   381:     let ps = remap_ps ps in
   382:     let exes = rexes exes in
   383:     let ret = auxt ret in
   384:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_function (props,splice vs,(ps,traint),ret,exes));
   385:     (*
   386:     print_endline "NEW FUNCTION (clone):";
   387:     print_function syms.dfns bbdfns k;
   388:     *)
   389:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   390:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   391:     (*
   392:     print_endline ("Cal new usage of fun " ^ si k ^ ": " ^
   393:       catmap "," (fun (j,_) -> si j) calls);
   394:     *)
   395:     Hashtbl.add uses k calls
   396: 
   397:   | `BBDCL_var (vs,t) ->
   398:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_var (splice vs,auxt t))
   399: 
   400:   | `BBDCL_val (vs,t) ->
   401:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_val (splice vs,auxt t))
   402: 
   403:   | `BBDCL_tmp (vs,t) ->
   404:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_tmp (splice vs,auxt t))
   405: 
   406:   | `BBDCL_reglex (props,vs,(ps,traint),i,t,(a,j,h,m)) ->
   407:     let t = auxt t in
   408:     let ps = remap_ps ps in
   409:     let vs = splice vs in
   410:     let i = revar i in
   411:     let h2 = Hashtbl.create 13 in
   412:     Hashtbl.iter (fun x e -> Hashtbl.add h2 x (rexpr e)) h;
   413:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_reglex (props,vs,(ps,traint),i,t,(a,j,h2,m)));
   414:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   415:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   416:     Hashtbl.add uses k calls
   417: 
   418: 
   419:   | `BBDCL_regmatch (props,vs,(ps,traint),t,(a,j,h,m)) ->
   420:     let t = auxt t in
   421:     let ps = remap_ps ps in
   422:     let vs = splice vs in
   423:     let h2 = Hashtbl.create 13 in
   424:     Hashtbl.iter (fun x e -> Hashtbl.add h2 x (rexpr e)) h;
   425:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_regmatch (props,vs,(ps,traint),t,(a,j,h2,m)));
   426:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   427:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   428:     Hashtbl.add uses k calls
   429: 
   430: 
   431:   | `BBDCL_glr (props,vs,t,(prd,exes)) ->
   432:     let t = auxt t in
   433:     let vs = splice vs in
   434:     let exes = rexes exes in
   435:     let remap_glr g = match g with
   436:       | `Nonterm js -> `Nonterm (map revar js)
   437:       | x -> x (* terminal codes are invariant *)
   438:     in
   439:     let prd = map (fun (s,g) -> s,remap_glr g) prd in
   440:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_glr (props,vs,t,(prd,exes)));
   441:     let calls = try Hashtbl.find uses index with Not_found -> [] in
   442:     let calls = map (fun (j,sr) -> revar j,sr) calls in
   443:     Hashtbl.add uses k calls
   444: 
   445:   | `BBDCL_class (props,vs) ->
   446:     Hashtbl.add bbdfns k (id,parent,sr,`BBDCL_class (props,splice vs));
   447: 
   448:   | _ -> syserr sr ("[reparent1] Unexpected bbdcl " ^ string_of_bbdcl syms.dfns entry index)
   449: 
   450: (* make a copy all the descendants of i, changing any
   451:   parent which is i to the given new parent
   452: *)
   453: 
   454: let reparent_children syms (uses,child_map,bbdfns)
   455:   caller_vs callee_vs_len index parent relabel varmap
   456: =
   457:   let pp p = match p with None -> "NONE" | Some i -> si i in
   458:   (*
   459:   print_endline
   460:   (
   461:     "Renesting children of callee " ^ si index ^
   462:     " to caller " ^ pp parent ^
   463:      "\n  -- Caller vs len = " ^ si (length caller_vs) ^
   464:      "\n  -- Callee vs len = " ^ si (callee_vs_len)
   465:   );
   466:   *)
   467:   let closure = descendants child_map index in
   468:   assert (not (IntSet.mem index closure));
   469:   (*
   470:   let cl = ref [] in IntSet.iter (fun i -> cl := i :: !cl) closure;
   471:   print_endline ("Closure is " ^ catmap " " si !cl);
   472:   *)
   473:   let revariable = mk_remap syms.counter closure in
   474:   IntSet.iter
   475:   (fun i ->
   476:     let old_parent =
   477:       match Hashtbl.find bbdfns i with id,oldp,_,_ -> oldp
   478:     in
   479:     let new_parent: bid_t option =
   480:       match old_parent with
   481:       | None -> assert false
   482:       | Some p ->
   483:         if p = index then parent
   484:         else Some (Hashtbl.find revariable p)
   485:     in
   486:     reparent1 syms (uses,child_map,bbdfns) relabel varmap revariable
   487:     caller_vs callee_vs_len i new_parent
   488:   )
   489:   closure
   490:   ;
   491:   if syms.compiler_options.print_flag then begin
   492:     Hashtbl.iter
   493:     (fun i j ->
   494:       print_endline ("//Reparent " ^ si j ^ " <-- " ^ si i)
   495:     )
   496:     revariable
   497:   end
   498:   ;
   499:   revariable
   500: 
   501: 
   502: (* Heavy inlining routine. This routine can inline
   503: any procedure. The basic operation is emit the body
   504: of the target procedure. We have to do the following to
   505: make it all work.
   506: 
   507: (1) Each declared label is replaced by a fresh one,
   508: and all jumps to these labels modified accordingly.
   509: 
   510: (2) Variables are replaced by fresh ones. This requires
   511: making additions to the output bound tables. References
   512: to the variables are modified. Note the parent is the
   513: caller now.
   514: 
   515: (3) Paremeters are replaced like variables, initialised
   516: by the arguments.
   517: 
   518: (4) Any type variables instantiated by the call must
   519: also be instantiated in body expressions, as well as
   520: the typing of any generated variables.
   521: 
   522: (5) If the procedure has any nested procedures, they
   523: also must be replaced in toto by fresh ones, reparented
   524: to the caller so that any calls to them will access
   525: the fresh variables in the caller.
   526: 
   527: Note that the cache of children of the caller will
   528: be wrong after the inlining (it may have acquired new
   529: variables or procedure children).
   530: 
   531: Note that this inlining procedure is NOT recursive!
   532: Its a flat one level inlining. This ensures recursive
   533: calls don't cause an infinite unrolling, and hopefully
   534: prevent gross bloat.
   535: *)
   536: 
   537: let mk_label_map syms exes =
   538:   let h = Hashtbl.create 97 in
   539:   let aux = function
   540:   | `BEXE_label (sr,s) ->
   541:     let n = !(syms.counter) in
   542:     incr syms.counter;
   543:     let s' =  "_" ^ si n in
   544:     Hashtbl.add h s s'
   545:   | _ -> ()
   546:   in
   547:     iter aux exes;
   548:     h
   549: 
   550: let idt t = t
   551: let subarg syms bbdfns argmap exe =
   552:   (*
   553:   print_endline ("[subarg] Checking " ^ string_of_bexe syms.dfns 0 exe);
   554:   *)
   555:   let rec rpl x = match map_tbexpr ident rpl idt x with
   556:   (* No need to check ts or type here *)
   557:   | (`BEXPR_name (i,_),_) as x ->
   558:     (try
   559:       let x' = Hashtbl.find argmap i in
   560:       (*
   561:       print_endline ("Replacing variable " ^ si i ^ " with " ^ sbe syms.dfns x');
   562:       *)
   563:       x'
   564:       with Not_found -> x)
   565:   | x -> x
   566:   in
   567:   reduce_bexe bbdfns (map_bexe idt rpl idt idt idt exe)
   568: 
   569: (* NOTE: result is in reversed order *)
   570: let gen_body syms (uses,child_map,bbdfns) id
   571:   varmap ps relabel revariable exes argument
   572:   sr caller callee vs callee_vs_len inline_method props
   573: =
   574:   let argument = reduce_tbexpr bbdfns argument in
   575:   let psis: int list = map (fun (_,(i,_)) -> i) ps in
   576:   let inline_method = match inline_method with
   577:   | `Lazy ->
   578:     if
   579:       Flx_call.is_recursive uses callee or
   580:       is_tailed psis exes
   581:     then `Eager
   582:     else `Lazy
   583:   | `Eager -> `Eager
   584:   in
   585: 
   586:   (* HACKERY *)
   587: 
   588:   (*
   589:   let inline_method = `Eager in
   590:   *)
   591: 
   592:   (*
   593:   print_endline ("Inlining " ^ si callee ^ " into " ^ si caller);
   594:   *)
   595:   (*
   596:   begin match inline_method with
   597:   | `Eager ->
   598:     print_endline ("Eager INLINING " ^ id ^ "<"^si callee^">("^sbe syms.dfns argument^") into " ^ si caller ^ " .. INPUT:");
   599:   | `Lazy ->
   600:     print_endline ("Lazy INLINING " ^ id ^ "<"^si callee^">("^sbe syms.dfns argument^") into " ^ si caller ^ " .. INPUT:");
   601:   end
   602:   ;
   603:   iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) exes;
   604:   *)
   605:   let paramtype  =
   606:     let pt =
   607:       let pts = map (fun (_,(_,t)) -> t) ps in
   608:       match pts with
   609:       | [x] -> x
   610:       | x -> `BTYP_tuple x
   611:     in
   612:       varmap_subst varmap pt
   613:   in
   614: 
   615:   let caller_vars = map (fun (s,i) -> `BTYP_var (i,`BTYP_type)) vs in
   616:   let ge e = remap_expr syms bbdfns varmap revariable caller_vars callee_vs_len e in
   617:   let relab s = try Hashtbl.find relabel s with Not_found -> s in
   618:   let revar i = try Hashtbl.find revariable i with Not_found -> i in
   619:   let end_label_uses = ref 0 in
   620:   let end_label =
   621:     let end_index = !(syms.counter) in
   622:     incr syms.counter;
   623:     "_end_" ^ (si end_index)
   624:   in
   625: 
   626: 
   627:   let remap: bexe_t -> bexe_t list =  fun exe ->
   628:   match exe with
   629:   | `BEXE_axiom_check _ -> assert false
   630:   | `BEXE_call_prim (sr,i,ts,e2)  ->
   631:     let fixup i ts =
   632:       let auxt t = varmap_subst varmap t in
   633:       let ts = map auxt ts in
   634:       try
   635:         let j= Hashtbl.find revariable i in
   636:         j, vsplice caller_vars callee_vs_len ts
   637:       with Not_found -> i,ts
   638:     in
   639:     let i,ts = fixup i ts in
   640:     [`BEXE_call_prim (sr,i,ts, ge e2)]
   641: 
   642:   | `BEXE_call_direct (sr,i,ts,e2)  ->
   643:     let fixup i ts =
   644:       let auxt t = varmap_subst varmap t in
   645:       let ts = map auxt ts in
   646:       try
   647:         let j= Hashtbl.find revariable i in
   648:         j, vsplice caller_vars callee_vs_len ts
   649:       with Not_found -> i,ts
   650:     in
   651:     let i,ts = fixup i ts in
   652:     [`BEXE_call_direct (sr,i,ts, ge e2)]
   653: 
   654:   | `BEXE_call_method_direct (sr,e1,i,ts,e2)  ->
   655:     let fixup i ts =
   656:       let auxt t = varmap_subst varmap t in
   657:       let ts = map auxt ts in
   658:       try
   659:         let j= Hashtbl.find revariable i in
   660:         j, vsplice caller_vars callee_vs_len ts
   661:       with Not_found -> i,ts
   662:     in
   663:     let i,ts = fixup i ts in
   664:     [`BEXE_call_method_direct (sr,ge e1,i,ts, ge e2)]
   665: 
   666:   | `BEXE_call_method_stack (sr,e1,i,ts,e2)  ->
   667:     let fixup i ts =
   668:       let auxt t = varmap_subst varmap t in
   669:       let ts = map auxt ts in
   670:       try
   671:         let j= Hashtbl.find revariable i in
   672:         j, vsplice caller_vars callee_vs_len ts
   673:       with Not_found -> i,ts
   674:     in
   675:     let i,ts = fixup i ts in
   676:     [`BEXE_call_method_stack (sr,ge e1,i,ts, ge e2)]
   677: 
   678:   | `BEXE_jump_direct (sr,i,ts,e2)  ->
   679:     let fixup i ts =
   680:       let auxt t = varmap_subst varmap t in
   681:       let ts = map auxt ts in
   682:       try
   683:         let j= Hashtbl.find revariable i in
   684:         j, vsplice caller_vars callee_vs_len ts
   685:       with Not_found -> i,ts
   686:     in
   687:     let i,ts = fixup i ts in
   688:     [`BEXE_jump_direct (sr,i,ts, ge e2)]
   689: 
   690:   | `BEXE_call_stack (sr,i,ts,e2)  -> assert false
   691: 
   692:   | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2) ->
   693:     let auxt t = varmap_subst varmap t in
   694:     let ts = map auxt ts in
   695:     let ts = vsplice caller_vars callee_vs_len ts in
   696:     let rv i = try Hashtbl.find revariable i with Not_found -> i in
   697:     [`BEXE_apply_ctor (sr,rv i1, rv i2,ts,rv i3,ge e2)]
   698: 
   699:   | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2) ->
   700:     let auxt t = varmap_subst varmap t in
   701:     let ts = map auxt ts in
   702:     let ts = vsplice caller_vars callee_vs_len ts in
   703:     let rv i = try Hashtbl.find revariable i with Not_found -> i in
   704:     [`BEXE_apply_ctor_stack (sr,rv i1, rv i2,ts,rv i3,ge e2)]
   705: 
   706:   | `BEXE_call (sr,e1,e2)  -> [reduce_bexe bbdfns (`BEXE_call (sr,ge e1, ge e2))]
   707:   | `BEXE_jump (sr,e1,e2)  -> assert false
   708: 
   709:   | `BEXE_loop (sr,i,e) -> assert false
   710: 
   711:   | `BEXE_assert (sr,e) -> [`BEXE_assert (sr, ge e)]
   712:   | `BEXE_assert2 (sr,sr2,e) -> [`BEXE_assert2 (sr, sr2, ge e)]
   713: 
   714:   | `BEXE_ifgoto (sr,e,lab) -> [`BEXE_ifgoto (sr,ge e, relab lab)]
   715:   | `BEXE_ifnotgoto (sr,e,lab) -> [`BEXE_ifnotgoto (sr,ge e, relab lab)]
   716:   | `BEXE_fun_return (sr,e) -> [`BEXE_fun_return (sr, ge e)]
   717:   | `BEXE_assign (sr,e1,e2) -> [`BEXE_assign (sr, ge e1, ge e2)]
   718:   | `BEXE_init (sr,i,e) -> [`BEXE_init (sr,revar i, ge e)]
   719:   | `BEXE_svc (sr,i)  -> [`BEXE_svc (sr, revar i)]
   720: 
   721:   | `BEXE_code (sr,s)  as x -> [x]
   722:   | `BEXE_nonreturn_code (sr,s)  as x -> [x]
   723:   | `BEXE_goto (sr,lab) -> [`BEXE_goto (sr, relab lab)]
   724: 
   725: 
   726:   (* INLINING THING *)
   727:   | `BEXE_proc_return sr as x ->
   728:     incr end_label_uses;
   729:     [`BEXE_goto (sr,end_label)]
   730: 
   731:   | `BEXE_comment (sr,s) as x -> [x]
   732:   | `BEXE_nop (sr,s) as x -> [x]
   733:   | `BEXE_halt (sr,s) as x -> [x]
   734:   | `BEXE_label (sr,lab) -> [`BEXE_label (sr, relab lab)]
   735:   | `BEXE_begin as x -> [x]
   736:   | `BEXE_end as x -> [x]
   737:   in
   738:     let kind = match inline_method with
   739:       | `Lazy -> "Lazy "
   740:       | `Eager -> "Eager "
   741:     in
   742:     let rec fgc props s =
   743:       match props with
   744:       | [] -> String.concat ", " s
   745:       | `Generated x :: t -> fgc t (x :: s)
   746:       | _ :: t -> fgc t s
   747:     in
   748:     let source =
   749:       let x = fgc props [] in
   750:       if x <> "" then " (Generated "^x^")" else ""
   751:     in
   752:     (* add a comment for non-generated functions .. *)
   753:     let b =
   754:       ref
   755:       (
   756:         if source = "" && id <> "_init_" then
   757:           [`BEXE_comment (sr,(kind ^ "inline call to " ^ id ^source))]
   758:         else []
   759:       )
   760:     in
   761:     if inline_method = `Eager then begin
   762:       (* create a variable for the parameter *)
   763:       let parameter = !(syms.counter) in
   764:       incr syms.counter;
   765:       let param_id = "_p" ^ si parameter in
   766:       (*
   767:       print_endline ("Parameter assigned index " ^ si parameter);
   768:       *)
   769: 
   770:       (* create variables for parameter components *)
   771:       (* Whaaa??
   772:       if length ps > 1 then
   773:       for i = 1 to length ps do incr syms.counter done;
   774:        (* Initialise parameter to argument, but only if
   775:          the argument is not unit
   776:       *)
   777:       *)
   778:       if length ps > 0 then
   779:       begin
   780:         let x =
   781:           if length ps > 1
   782:           then begin
   783:             let entry = `BBDCL_var (vs,paramtype) in
   784:             let kids =
   785:               try Hashtbl.find child_map caller
   786:               with Not_found -> []
   787:             in
   788:             Hashtbl.replace child_map caller (parameter::kids);
   789:             Hashtbl.add bbdfns parameter (param_id,Some caller,sr,entry);
   790:             `BEXE_init (sr,parameter,argument)
   791:           end
   792:           else
   793:             let vid,(k,_) = hd ps in
   794:             let index = revar k in
   795:             `BEXE_init (sr,index,argument)
   796:         in
   797:         b := x :: !b;
   798: 
   799:         (* unpack argument *)
   800:         if length ps > 1 then
   801:         let ts = map (fun (_,i) -> `BTYP_var (i,`BTYP_type)) vs in
   802:         let p = `BEXPR_name (parameter,ts),paramtype in
   803:         let n = ref 0 in
   804:         iter
   805:         (fun (vid,(ix,prjt)) ->
   806:           let prjt = varmap_subst varmap prjt in
   807:           let prj = reduce_tbexpr bbdfns (`BEXPR_get_n (!n,p),prjt) in
   808:           let index = revar ix in
   809:           let x = `BEXE_init (sr,index,prj) in
   810:           b := x :: !b;
   811:           incr n
   812:         )
   813:         ps
   814:       end
   815:       ;
   816:       iter
   817:       (fun exe ->
   818:         iter
   819:         (fun x -> b := x :: !b)
   820:         (remap exe)
   821:       )
   822:       exes
   823:     end else if inline_method = `Lazy then begin
   824:       let argmap = Hashtbl.create 97 in
   825:       begin match length ps with
   826:       | 0 -> ()
   827:       | 1 ->
   828:         let vid,(k,_) = hd ps in
   829:         let index = revar k in
   830:         Hashtbl.add argmap index argument
   831:       | _ ->
   832:         let ts = map (fun (_,i) -> `BTYP_var (i,`BTYP_type)) vs in
   833:         let n = ref 0 in
   834:         iter
   835:         (fun (vid,(ix,prjt)) ->
   836:           let prjt = varmap_subst varmap prjt in
   837:           let prj = reduce_tbexpr bbdfns (`BEXPR_get_n (!n,argument),prjt) in
   838:           let index = revar ix in
   839:           Hashtbl.add argmap index prj;
   840:           incr n
   841:         )
   842:         ps
   843:       end
   844:       ;
   845:       (*
   846:       print_endline "argmap = ";
   847:       Hashtbl.iter
   848:       (fun i e ->
   849:         try
   850:         let id,_,_,_ = Hashtbl.find bbdfns i in
   851:         print_endline (id ^ "<"^ si i ^ "> --> " ^ sbe syms.dfns e)
   852:         with Not_found -> print_endline ("Can't find index .." ^ si i)
   853:       )
   854:       argmap
   855:       ;
   856:       print_endline "----::----";
   857:       *)
   858:       let sba = if length ps = 0 then
   859:         fun x -> b := x :: !b
   860:       else
   861:         fun x -> b := subarg syms bbdfns argmap x :: !b
   862:       in
   863:       iter
   864:       (fun exe -> iter sba (remap exe))
   865:       exes
   866:       ;
   867:       (*
   868:       print_endline "Lazy evaluation, output=";
   869:       iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) (rev !b);
   870:       *)
   871:       (* substitute in kids too *)
   872:       if length ps > 0 then begin
   873:         let closure = descendants child_map callee in
   874:         (*
   875:            let cl = ref [] in IntSet.iter (fun i -> cl := i :: !cl) closure;
   876:            print_endline ("Closure is " ^ catmap " " si !cl);
   877:         *)
   878:         let kids =
   879:           IntSet.fold
   880:           (fun i s -> IntSet.add (revar i) s)
   881:           closure
   882:           IntSet.empty
   883:         in
   884:         IntSet.iter (fun i ->
   885:           let id,parent,sr,entry = Hashtbl.find bbdfns i in
   886:           match entry with
   887:           | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
   888:             let exes = map (subarg syms bbdfns argmap) exes in
   889:             recal_exes_usage syms uses sr i ps exes;
   890:             Hashtbl.replace bbdfns i
   891:             (id,parent,sr,`BBDCL_function (props,vs,(ps,traint),ret,exes))
   892:           | `BBDCL_procedure (props,vs,(ps,traint),exes) ->
   893:             (*
   894:             print_endline ("MODIFY " ^ si i);
   895:             *)
   896:             let exes = map (subarg syms bbdfns argmap) exes in
   897:             recal_exes_usage syms uses sr i ps exes;
   898:             Hashtbl.replace bbdfns i
   899:             (id,parent,sr,`BBDCL_procedure (props,vs,(ps,traint),exes))
   900:           | _ -> ()
   901:         )
   902:         kids
   903:       end
   904:     end
   905:     ;
   906:     let trail_jump = match !b with
   907:       | `BEXE_goto (_,lab)::_ when lab = end_label -> true
   908:       | _ -> false
   909:     in
   910:     if trail_jump then
   911:       (b := tl !b; decr end_label_uses)
   912:     ;
   913:     if !end_label_uses > 0 then
   914:       b := (`BEXE_label (sr,end_label)) :: !b
   915:     ;
   916:     (*
   917:     print_endline ("INLINING " ^ id ^ " into " ^ si caller ^ " .. OUTPUT:");
   918:     iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) (rev !b);
   919:     print_endline ("END OUTPUT for " ^ id);
   920:     *)
   921:     !b
   922: 
   923: 
   924: (* CALL LIFTING. What this does is transform a call:
   925: 
   926:   call (f a) arg
   927: 
   928:   by replacing it with the body of f,
   929:   in which every
   930: 
   931:   return x
   932: 
   933:   is replaced by
   934: 
   935:   call x arguemnt
   936: 
   937:   This converts  f from a function returning
   938:   a procedure, to a procedure which executes that
   939:   procedure.
   940: 
   941:   NOTE: this is a special case of the distributive law.
   942: 
   943:   f (if c then a else b) v => if c then f a v else f b v
   944: 
   945: *)
   946: 
   947: let call_lifting syms (uses,child_map,bbdfns) caller caller_vs callee ts a argument =
   948:   (*
   949:   print_endline "DOING CALL LIFTING";
   950:   *)
   951:   let id,parent,sr,entry = Hashtbl.find bbdfns callee in
   952:   match entry with
   953:   | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
   954:     (*
   955:     print_endline ("Found procedure "^id^": Inline it!");
   956:     *)
   957:     let relabel = mk_label_map syms exes in
   958:     let varmap = mk_varmap vs ts in
   959:     let callee_vs_len = length vs in
   960: 
   961:     let revariable = reparent_children
   962:       syms (uses,child_map,bbdfns)
   963:       caller_vs callee_vs_len callee (Some caller) relabel varmap
   964:     in
   965:     (* use the inliner to handle the heavy work *)
   966:     let body =
   967:       gen_body syms (uses,child_map,bbdfns) id varmap ps relabel revariable
   968:       exes a sr caller callee caller_vs callee_vs_len `Lazy props
   969:     in
   970: 
   971:     (* replace all function returns with tailed calls *)
   972:     let body2 = ref [] in
   973:     let n = !(syms.counter) in incr (syms.counter);
   974:     let end_label = "_end_call_lift_" ^ si n in
   975:     body2 := `BEXE_label (sr,end_label) :: !body2;
   976:     iter
   977:       (function
   978:       | `BEXE_fun_return (sr,e) ->
   979:         (* NOTE REVERSED ORDER *)
   980:         let call_instr =
   981:           (match e with
   982:           | `BEXPR_closure (i,ts),_ ->
   983:             `BEXE_call_direct (sr,i,ts,argument)
   984:           | `BEXPR_method_closure (obj,i,ts),_ ->
   985:             `BEXE_call_method_direct (sr,obj,i,ts,argument)
   986:           | _ ->
   987:             `BEXE_call (sr,e,argument)
   988:           )
   989:         in
   990:         body2 := `BEXE_goto (sr,end_label) :: !body2;
   991:         body2 := call_instr :: !body2;
   992:       | x -> body2 := x::!body2
   993:       )
   994:       body
   995:     ;
   996:     (*
   997:     print_endline (
   998:      catmap "\n" (string_of_bexe syms.dfns 0) !body2
   999:     )
  1000:     ;
  1001:     *)
  1002:     !body2 (* forward order *)
  1003: 
  1004:   | _ -> assert false
  1005: 
  1006: let inline_tail_apply syms (uses,child_map,bbdfns) caller caller_vs callee ts a =
  1007:   (* TEMPORARY .. this should be allowed for unrolling but we do not do that yet *)
  1008:   assert (callee <> caller);
  1009:   let id,parent,sr,entry = Hashtbl.find bbdfns callee in
  1010:   match entry with
  1011:   | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
  1012:     let id2,_,_,_ = Hashtbl.find bbdfns caller in
  1013:     (*
  1014:     print_endline
  1015:     (
  1016:       "TAIL Inlining function "^id^
  1017:       "<"^si callee^">"^
  1018:       "[" ^ catmap "," (sbt syms.dfns) ts ^ "] into " ^ id2 ^ "<" ^ si caller ^">"
  1019:     );
  1020:     flush stdout;
  1021:     *)
  1022:     let relabel = mk_label_map syms exes in
  1023:     let varmap = mk_varmap vs ts in
  1024:     let callee_vs_len = length vs in
  1025: 
  1026:     let revariable = reparent_children
  1027:       syms (uses,child_map,bbdfns)
  1028:       caller_vs callee_vs_len callee (Some caller) relabel varmap
  1029:     in
  1030: 
  1031:     (* use the inliner to handle the heavy work *)
  1032:     let body =
  1033:       gen_body syms (uses,child_map,bbdfns) id varmap ps relabel revariable
  1034:       exes a sr caller callee caller_vs callee_vs_len `Lazy props
  1035:     in
  1036:     rev body
  1037: 
  1038:   | _ -> assert false
  1039: 
  1040: let inline_function syms (uses,child_map,bbdfns) caller caller_vs callee ts a varindex =
  1041:   let id,parent,sr,entry = Hashtbl.find bbdfns callee in
  1042:   match entry with
  1043:   | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
  1044:     (*
  1045:     print_endline
  1046:     (
  1047:       "Inlining function "^id^
  1048:       "<"^si callee^">"^
  1049:       "[" ^ catmap "," (sbt syms.dfns) ts ^ "]"^
  1050:       "var="^ si varindex
  1051:     );
  1052:     flush stdout;
  1053:     *)
  1054:     let relabel = mk_label_map syms exes in
  1055:     let varmap = mk_varmap vs ts in
  1056:     let callee_vs_len = length vs in
  1057: 
  1058:     let revariable = reparent_children
  1059:       syms (uses,child_map,bbdfns)
  1060:       caller_vs callee_vs_len callee (Some caller) relabel varmap
  1061:     in
  1062: 
  1063:     (* use the inliner to handle the heavy work *)
  1064:     let body =
  1065:       gen_body syms (uses,child_map,bbdfns) id varmap ps relabel revariable
  1066:       exes a sr caller callee caller_vs callee_vs_len `Lazy props
  1067:     in
  1068: 
  1069:     (*
  1070:     print_endline "Replace returns with inits";
  1071:     *)
  1072:     (* replace all function returns with variable initialisations *)
  1073:     let body2 = ref [] in
  1074:     let n = !(syms.counter) in incr (syms.counter);
  1075:     let end_label = "_end_inline_" ^ Flx_name.cid_of_flxid id ^ "_"^ si n in
  1076:     let t = ref None in
  1077:     let end_label_used = ref false in
  1078:     iter
  1079:       (function
  1080:       | `BEXE_fun_return (sr,((_,t') as e)) ->
  1081:         t := Some t';
  1082:         if not (!body2 == []) then begin
  1083:           body2 := `BEXE_goto (sr,end_label) :: !body2;
  1084:           end_label_used := true
  1085:         end
  1086:         ;
  1087:         let call_instr = `BEXE_init (sr,varindex,e) in
  1088:         (*
  1089:         print_endline ("Replacing return with init: " ^ string_of_bexe syms.dfns 0 call_instr);
  1090:         *)
  1091:         body2 := call_instr :: !body2;
  1092: 
  1093:       | x -> body2 := x::!body2
  1094:       )
  1095:       body
  1096:     ;
  1097:     (* Ugghhh *)
  1098:     if !end_label_used then
  1099:       body2 := !body2 @ [`BEXE_label (sr,end_label)]
  1100:     ;
  1101:     (*
  1102:     print_endline (
  1103:      catmap "\n" (string_of_bexe syms.dfns 0) !body2
  1104:     )
  1105:     ;
  1106:     *)
  1107:     !body2 (* forward order *)
  1108: 
  1109:   | _ -> assert false
  1110: 
  1111: (* this routine changes direct applications into a named
  1112:   value plus an initialisation of that value: the argument
  1113:   should have already been processed bottom up, ie. already
  1114:   be in canonical form
  1115: *)
  1116: let bunravel syms bbdfns ts e =
  1117:   let counter = syms.counter in
  1118:   let vars = ref [] in
  1119:   let rec urv e =
  1120:     match map_tbexpr ident urv ident e with
  1121:     | (`BEXPR_apply_direct _,t) as x ->
  1122:       let n = !counter in incr counter;
  1123:       print_endline ("New variable " ^ si n);
  1124:       vars := (n,x) :: !vars ;
  1125:       `BEXPR_name (n,ts),t
  1126:     | (`BEXPR_apply ((`BEXPR_apply_direct _,t'),a),t as x) ->
  1127:       print_endline ("Indirect apply direct!! " ^ sbe syms.dfns x);
  1128:       x
  1129:     | (`BEXPR_apply (f,a),t as x) ->
  1130:       print_endline ("Indirect apply " ^ sbe syms.dfns x);
  1131:       x
  1132: 
  1133:     | x -> x
  1134:   in
  1135:     let x = urv e in
  1136:     x,!vars
  1137: 
  1138: (* note u sr e must return exes in reverse order, this
  1139:   function however returns exes in forward order
  1140: *)
  1141: let expand_exe syms bbdfns u exe =
  1142:   let xs =
  1143:     match exe with
  1144:     | `BEXE_axiom_check _ -> assert false
  1145:     | `BEXE_call_prim (sr,i,ts,e2) ->
  1146:       let e,xs = u sr e2 in
  1147:       `BEXE_call_prim (sr,i,ts,e) :: xs
  1148: 
  1149:     | `BEXE_call_stack (sr,i,ts,e2) -> assert false
  1150: 
  1151:     | `BEXE_call_direct (sr,i,ts,e2) ->
  1152:       let e,xs = u sr e2 in
  1153:       `BEXE_call_direct (sr,i,ts,e) :: xs
  1154: 
  1155:     | `BEXE_call_method_direct (sr,e1,i,ts,e2) ->
  1156:       let e1,xs1 = u sr e1 in
  1157:       let e2,xs2 = u sr e2 in
  1158:       `BEXE_call_method_direct (sr,e1,i,ts,e2) :: xs2 @ xs1
  1159: 
  1160:     | `BEXE_call_method_stack (sr,e1,i,ts,e2) ->
  1161:       let e1,xs1 = u sr e1 in
  1162:       let e2,xs2 = u sr e2 in
  1163:       `BEXE_call_method_stack (sr,e1,i,ts,e2) :: xs2 @ xs1
  1164: 
  1165:     | `BEXE_jump_direct (sr,i,ts,e2) ->
  1166:       let e,xs = u sr e2 in
  1167:       `BEXE_jump_direct (sr,i,ts,e) :: xs
  1168: 
  1169:     | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2) ->
  1170:       let e,xs = u sr e2 in
  1171:       `BEXE_apply_ctor (sr,i1,i2,ts,i3,e) :: xs
  1172: 
  1173:     | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2) ->
  1174:       let e,xs = u sr e2 in
  1175:       `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e) :: xs
  1176: 
  1177:     | `BEXE_assign (sr,e1,e2) ->
  1178:       let e1,xs1 = u sr e1 in
  1179:       let e2,xs2 = u sr e2 in
  1180:       `BEXE_assign (sr,e1,e2) :: xs2 @ xs1
  1181: 
  1182:     | `BEXE_assert (sr,e) ->
  1183:       let e,xs = u sr e in
  1184:       `BEXE_assert (sr,e) :: xs
  1185: 
  1186:     | `BEXE_assert2 (sr,sr2,e) ->
  1187:       let e,xs = u sr e in
  1188:       `BEXE_assert2 (sr,sr2,e) :: xs
  1189: 
  1190:     (* preserve call lift pattern ??*)
  1191:     | `BEXE_call (sr,(`BEXPR_apply_direct(i,ts,e1),t),e2) ->
  1192:       let e1,xs1 = u sr e1 in
  1193:       let e2,xs2 = u sr e2 in
  1194:       `BEXE_call (sr,(`BEXPR_apply_direct(i,ts,e1),t),e2) :: xs2 @ xs1
  1195: 
  1196:     | `BEXE_call (sr,e1,e2) ->
  1197:       let e1,xs1 = u sr e1 in
  1198:       let e2,xs2 = u sr e2 in
  1199:       reduce_bexe bbdfns (`BEXE_call (sr,e1,e2)) :: xs2 @ xs1
  1200: 
  1201:     | `BEXE_jump (sr,e1,e2) ->
  1202:       let e1,xs1 = u sr e1 in
  1203:       let e2,xs2 = u sr e2 in
  1204:       reduce_bexe bbdfns (`BEXE_jump (sr,e1,e2)) :: xs2 @ xs1
  1205: 
  1206:     | `BEXE_loop (sr,i,e) ->
  1207:       let e,xs = u sr e in
  1208:       `BEXE_loop (sr,i,e) :: xs
  1209: 
  1210:     | `BEXE_ifgoto (sr,e,lab) ->
  1211:       let e,xs = u sr e in
  1212:       `BEXE_ifgoto (sr,e,lab) :: xs
  1213: 
  1214:     | `BEXE_ifnotgoto (sr,e,lab) ->
  1215:       let e,xs = u sr e in
  1216:       `BEXE_ifnotgoto (sr,e,lab) :: xs
  1217: 
  1218:     (* preserve tail call pattern -- used by both
  1219:        tail-rec eliminator
  1220:        and by call lifter (which converts returns to calls)
  1221:     *)
  1222:     | `BEXE_fun_return (sr,(`BEXPR_apply_direct(i,ts,e),t)) ->
  1223:       let e,xs = u sr e in
  1224:       `BEXE_fun_return (sr,(`BEXPR_apply_direct(i,ts,e),t)) :: xs
  1225: 
  1226:     | `BEXE_fun_return (sr,e) ->
  1227:       let e,xs = u sr e in
  1228:       `BEXE_fun_return (sr,e) :: xs
  1229: 
  1230:     | `BEXE_init (sr,i,e) ->
  1231:       let e,xs = u sr e in
  1232:       `BEXE_init (sr,i,e) :: xs
  1233: 
  1234:     | `BEXE_svc _
  1235:     | `BEXE_label _
  1236:     | `BEXE_goto _
  1237:     | `BEXE_code _
  1238:     | `BEXE_nonreturn_code _
  1239:     | `BEXE_proc_return _
  1240:     | `BEXE_comment _
  1241:     | `BEXE_nop _
  1242:     | `BEXE_halt _
  1243:     | `BEXE_begin
  1244:     | `BEXE_end
  1245:       -> [exe]
  1246:   in
  1247:     let xs = rev xs in
  1248:     xs
  1249: 
  1250: (* output in reverse order *)
  1251: let xmap_bexe syms (child_map,bbdfns) caller vs exe : bexe_t list =
  1252:   let ts = map (fun (_,i)-> `BTYP_var (i,`BTYP_type)) vs in
  1253:   let u sr e =
  1254:     let x,xs = bunravel syms bbdfns ts e in
  1255:     iter
  1256:     (fun (i,((x,t) as e)) ->
  1257:       let id = "_urv_" ^ si i  in
  1258:       (*
  1259:       print_endline (id ^ "[" ^ catmap "," (sbt syms.dfns) ts ^ "]");
  1260:       *)
  1261:       let entry = `BBDCL_val (vs,t) in
  1262:       Hashtbl.add bbdfns i (id,Some caller,sr,entry);
  1263:       let kids =
  1264:         try Hashtbl.find child_map caller
  1265:         with Not_found -> []
  1266:       in
  1267:       Hashtbl.replace child_map caller (i::kids)
  1268:     )
  1269:     xs
  1270:     ;
  1271:     let inits = map (fun (i,e)->`BEXE_init (sr,i,e)) xs in
  1272:     x,inits
  1273:   in
  1274:   expand_exe syms bbdfns u exe
  1275: 
  1276: let heavy_inline_call syms (uses,child_map,bbdfns)
  1277:   caller caller_vs callee ts argument id sr (props, vs, (ps,traint), exes)
  1278: =
  1279:   (*
  1280:   print_endline ("INLINING CALL to " ^ id ^"<"^ si callee^">("^sbe syms.dfns argument^")");
  1281:   print_endline ("In procedure " ^ si caller ^ " with vs=" ^ string_of_vs caller_vs);
  1282:   print_endline ("Callee is " ^ id ^ "<"^si callee ^ "> with ts = " ^ catmap "," (sbt syms.dfns) ts);
  1283:   print_endline ("Callee vs=" ^ string_of_vs vs);
  1284:   *)
  1285:   let caller_vs_len = length caller_vs in
  1286:   let callee_vs_len = length vs in
  1287:   (*
  1288:   print_endline ("In the callee and its children,");
  1289:   print_endline ("The callee vs are elided and replaced by the caller vs");
  1290:   print_endline ("ELIDE: first " ^ si callee_vs_len ^ ", PREPEND " ^ si caller_vs_len);
  1291:   print_endline ("This works by instantiating the callee vs with the calls ts");
  1292:   *)
  1293:   assert(length vs = length ts);
  1294: 
  1295:   (*
  1296:   print_endline ("Found procedure "^id^": Inline it!");
  1297:   *)
  1298:   let relabel = mk_label_map syms exes in
  1299:   let varmap = mk_varmap vs ts in
  1300:   let revariable = reparent_children
  1301:     syms (uses,child_map,bbdfns)
  1302:     caller_vs callee_vs_len callee (Some caller) relabel varmap
  1303:   in
  1304:   let xs = gen_body syms (uses,child_map,bbdfns) id
  1305:     varmap ps relabel revariable exes
  1306:     argument sr caller callee caller_vs callee_vs_len `Lazy props
  1307:   in
  1308:     rev xs (* forward order *)
  1309: 
  1310: (* Dependency analyser. This should be generalised,
  1311: but for now we only use it in tail calls.
  1312: 
  1313: We wish to discover what *local* vals an expression e in
  1314: some routine i depends on.
  1315: 
  1316: These are (a) the symbols manifestly used in the expression,
  1317: and (b) any variable used by any function that is called.
  1318: 
  1319: We can calculate this, expensively as the union of the
  1320: use closures of each symbol in the expression intersected
  1321: with the candidate locals.
  1322: *)
  1323: 
  1324: 
  1325: (* note returns exes in reverse order *)
  1326: (* This routine analyses an expression to see if it has  the form
  1327: 
  1328:   f a
  1329: 
  1330: If so it is replaced by v and a statement v = f a, then
  1331: this initialisation is replaced by the body of f
  1332: with a replacing the parameter,
  1333: where returns are replaced by initialisations of v
  1334: and a goto the end of the routine.
  1335: 
  1336: Then in the special case the last line of the body
  1337: resolves to the form
  1338: 
  1339:   v = e'
  1340: 
  1341: the expression is replaced by e'. This works by a quirk,
  1342: that this code must have come from a sole tail return
  1343: in the body. If there were more than one return,
  1344: prior returns would be a return to a label after it,
  1345: however the inliner doesn't generate the label at the
  1346: end for a sole tail return, so we can assume this
  1347: is the only return.
  1348: 
  1349: The result leaves an expression in a place where
  1350: a tail call might be recognized, avoiding a temporary
  1351: which prevents simplistic patterns representing data
  1352: and control flow. Although its a hack, it is important
  1353: to ensure trivial functions have no overhead.
  1354: 
  1355: Note this routine, in itself, does NOT rescan anything:
  1356: there is no recursion -- other than the recursive traversal
  1357: of the original expression, done by the 'aux' function.
  1358: *)
  1359: 
  1360: let inlining_complete bbdfns i =
  1361:   let _,_,_,entry = Hashtbl.find bbdfns i in
  1362:   match entry with
  1363:   | `BBDCL_function (props,_,_,_,_)
  1364:   | `BBDCL_procedure (props,_,_,_) ->
  1365:     mem `Inlining_complete props
  1366:   | _ -> assert false
  1367: 
  1368: let rec special_inline syms (uses,child_map,bbdfns) caller_vs caller excludes sr e =
  1369:   (*
  1370:   print_endline ("Special inline " ^ sbe syms.dfns e); flush stdout;
  1371:   *)
  1372:   let exes' = ref [] in
  1373:   let id x = x in
  1374:   let rec aux e = match map_tbexpr id aux id e with
  1375:   | ((`BEXPR_apply_direct (callee,ts,a),t) as e)
  1376:   | (((`BEXPR_apply(  (`BEXPR_closure (callee,ts),_) ,a)),t) as e)
  1377:     when
  1378:       not (mem callee excludes)
  1379:     ->
  1380:       heavily_inline_bbdcl syms (uses,child_map,bbdfns) (callee::excludes) callee;
  1381:       let id,parent,sr,entry = Hashtbl.find bbdfns callee in
  1382:       begin match entry with
  1383:       | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
  1384:         if
  1385:           not (mem `NoInline props) &&
  1386:           (
  1387:             mem `Inline props ||
  1388:             length exes <= syms.compiler_options.max_inline_length
  1389:           ) &&
  1390:          (
  1391:             (* only inline a recursive call to a child *)
  1392:             not (Flx_call.is_recursive_call uses caller callee) ||
  1393:             is_child child_map caller callee
  1394:          )
  1395:         then
  1396:             begin
  1397:               (*
  1398:               heavily_inline_bbdcl syms (uses,child_map,bbdfns) (callee::excludes) callee;
  1399:               *)
  1400:               if inlining_complete bbdfns callee then begin
  1401:                 (*
  1402:                 print_endline ("Special inline " ^ si caller ^" calls " ^ si callee);
  1403:                 *)
  1404:                 (* GENERAL CASE -- we need to add a variable *)
  1405:                 let urv = !(syms.counter) in incr (syms.counter);
  1406:                 (* inline the code, replacing returns with variable inits *)
  1407:                 let xs =
  1408:                    inline_function syms (uses,child_map,bbdfns) caller caller_vs callee ts a urv
  1409:                 in
  1410:                 match rev xs with
  1411:                 (* SPECIAL CASE DETECTOR: if the inlined function
  1412:                   terminates with an initialisation of the new variable,
  1413:                   ignore the variable and use the value used to initialise
  1414:                   it instead. This is sure to be the result of the sole
  1415:                   trailing return. If there were another return, a
  1416:                   jump to the end of the function would be needed,
  1417:                   past this initialisation, which would require a label
  1418:                   at the end of the function
  1419: 
  1420:                   Note this is a bad form of 'apply lifting'.
  1421:                   We should be able to inline
  1422: 
  1423:                   f (g x)
  1424: 
  1425:                   by inlining g x, and replacing 'return e'
  1426:                   with 'v = f e' everywhere. instead we get
  1427:                   v = e in various places, then f v.
  1428: 
  1429:                   To do this right we need to see a double application.
  1430:                 *)
  1431:                 | [] -> assert false
  1432:                 | `BEXE_init (sr,j,e') :: tail ->
  1433:                   assert (j==urv);
  1434:                   (*
  1435:                   print_endline "DETECTED SPECIAL CASE";
  1436:                   print_endline "Outputing tail:";
  1437:                   iter (fun x -> print_endline (string_of_bexe syms.dfns 0 x)) (rev tail);
  1438:                   print_endline ("Expr: " ^ sbe syms.dfns e');
  1439:                   *)
  1440:                   exes' := tail @ !exes';
  1441:                   e'
  1442:                 | rxs ->
  1443:                   let urvid = "_urv" ^ si urv in
  1444:                   add_child child_map caller urv;
  1445:                   add_use uses caller urv sr;
  1446:                   let entry = `BBDCL_val (caller_vs,t) in
  1447:                   Hashtbl.add bbdfns urv (urvid,Some caller,sr,entry);
  1448: 
  1449:                   exes' := rxs @ !exes';
  1450:                   let ts = map (fun (_,i)-> `BTYP_var (i,`BTYP_type)) caller_vs in
  1451:                   `BEXPR_name (urv,ts),t
  1452:               end
  1453:               else e
  1454:             end
  1455:         else e
  1456:       | _ -> e
  1457:       end
  1458: 
  1459:   | x -> x
  1460:   in
  1461:    let e = aux e in (* we need left to right evaluation here ..*)
  1462:    e,!exes'
  1463: 
  1464: 
  1465: and heavy_inline_calls
  1466:   syms (uses,child_map,bbdfns)
  1467:   caller_vs caller excludes exes
  1468: =
  1469:   let hic callee exes =
  1470:     (*
  1471:     print_endline "Rescanning ..";
  1472:     *)
  1473:     heavy_inline_calls syms (uses,child_map,bbdfns)
  1474:     caller_vs caller (callee::excludes) exes
  1475:   in
  1476: 
  1477:   (* The function ee applies the special inlining routine
  1478:     to all subexpressions of an expression, bottom up
  1479:     (that is, inside out).
  1480:   *)
  1481: 
  1482:   let sinl sr e = special_inline syms (uses,child_map,bbdfns) caller_vs caller (caller::excludes) sr e in
  1483:   let ee exe = expand_exe syms bbdfns sinl exe in
  1484:   let exes' = ref [] in (* reverse order *)
  1485:   iter  (* each exe *)
  1486:   (fun exeIN ->
  1487:     let xs = ee exeIN in
  1488:     (*
  1489:     print_endline ("EXE[in] =" ^ string_of_bexe syms.dfns 0 exeIN);
  1490:     iter (fun x -> print_endline ("EXE[out]=" ^ string_of_bexe syms.dfns 0 x)) xs;
  1491:     print_endline "--";
  1492:     *)
  1493: 
  1494:     (*
  1495:       This code RESCANS the result of the special inliner.
  1496:       The special inliner only handles function applications,
  1497:       this code should NOT handle them because iteration might
  1498:       lead to infinite recurse ..??
  1499: 
  1500:       This means the 'special cases' handled must be
  1501:       disjoint.
  1502: 
  1503:       Unfortunately, when inlining a function, we first
  1504:       inline into the function, then dump the result and
  1505:       rescan it. Consequently the recursion stop applied
  1506:       which leaves a direct non-tail self call will be
  1507:       rescanned here, and the function will be unfolded
  1508:       again .. in that process we also redo the special
  1509:       inlining .. infinite recursion. This is stopped
  1510:       by the flag which prevents inlining into a function
  1511:       more than once .. but that doesn't work if the
  1512:       function is cloned.
  1513:     *)
  1514:     iter (fun exe ->
  1515:     match exe with
  1516:     | `BEXE_call_direct (sr,callee,ts,argument)
  1517:       when not (mem callee excludes)
  1518:       ->
  1519:       heavily_inline_bbdcl syms (uses,child_map,bbdfns) (callee::excludes) callee;
  1520:       let id,parent,sr,entry = Hashtbl.find bbdfns callee in
  1521:       (*
  1522:       print_endline ("CALL DIRECT " ^ id ^ "<"^ si callee^">");
  1523:       *)
  1524:       begin match entry with
  1525:       | `BBDCL_procedure (props,vs,(ps,traint),exes) ->
  1526:         if
  1527:          mem `Inlining_complete props &&
  1528:          not (mem `NoInline props) &&
  1529:          (
  1530:               mem `Inline props ||
  1531:               length exes <= syms.compiler_options.max_inline_length
  1532:          ) &&
  1533:          (
  1534:             (* only inline a recursive call to a child *)
  1535:             not (Flx_call.is_recursive_call uses caller callee) ||
  1536:             is_child child_map caller callee
  1537:          )
  1538:         then begin
  1539:           (*
  1540:           print_endline "INLINE CANDIDATE DETECTED - CALL";
  1541:           *)
  1542:           let xs =
  1543:             heavy_inline_call syms (uses,child_map,bbdfns)
  1544:             caller caller_vs callee ts argument id sr (props,vs,(ps,traint),exes)
  1545:           in
  1546:             let xs = hic callee xs in
  1547:             exes' := rev xs @ !exes'
  1548:         end
  1549:         else
  1550:           exes' := exe :: !exes'
  1551: 
  1552:       | _ ->  exes' := exe :: !exes'
  1553:       end
  1554: 
  1555:     | `BEXE_call (sr,(`BEXPR_apply((`BEXPR_closure (callee,ts),_),a),_),argument) -> assert false
  1556:     | `BEXE_call (sr,(`BEXPR_apply_stack (callee,ts,a),_),argument) -> assert false
  1557: 
  1558:     | `BEXE_call (sr,(`BEXPR_apply_direct (callee,ts,a),_),argument)
  1559:       when not (mem callee excludes)
  1560:       ->
  1561:       (*
  1562:       print_endline "DETECTED CANDIDATE FOR CALL LIFTING ";
  1563:       print_endline ("In procedure " ^ si caller ^ " with vs=" ^ string_of_vs caller_vs);
  1564:       print_endline (string_of_bexe syms.dfns 0 exe);
  1565:       print_endline ("Callee is " ^ si callee ^ " with ts = " ^ catmap "," (sbt syms.dfns) ts);
  1566:       *)
  1567:       heavily_inline_bbdcl syms (uses,child_map,bbdfns) (callee::excludes) callee;
  1568:       let id,parent,sr,entry = Hashtbl.find bbdfns callee in
  1569:       begin match entry with
  1570:       | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
  1571:         if
  1572:           mem `Inlining_complete props &&
  1573:           not (mem `NoInline props) &&
  1574:           (
  1575:             mem `Inline props ||
  1576:             length exes <= syms.compiler_options.max_inline_length
  1577:           ) &&
  1578:           (
  1579:             (* only inline a recursive call to a child *)
  1580:             not (Flx_call.is_recursive_call uses caller callee) ||
  1581:             is_child child_map caller callee
  1582:           )
  1583:         then
  1584:           let xs =
  1585:              call_lifting syms (uses,child_map,bbdfns) caller caller_vs callee ts a argument
  1586:           in
  1587:             (* The recursion here is because the call is lifted,
  1588:             so there may be new calls that didn't previously
  1589:             exist, they need rescanning eg:
  1590: 
  1591:               call {if x then f else g endif} a
  1592:               -->
  1593:               if x then call f a else call f a endif
  1594: 
  1595:             creates new calls to f and g when now need
  1596:             to be scanned (possibly for a further lift,
  1597:             possibly for call inlining)
  1598: 
  1599:             The hassle here is that we might unfold
  1600:             an unrelated recursive function multiple times
  1601:             as a side effect.
  1602:             *)
  1603:             let xs = hic callee xs in
  1604:             exes' := rev xs @ !exes'
  1605:         else
  1606:           exes' := exe :: !exes'
  1607:       | _ -> exes' := exe :: !exes'
  1608:       end
  1609: 
  1610:     | `BEXE_init (sr,i,(`BEXPR_apply_direct (callee,ts,a),_))
  1611:       when not (mem callee excludes)  ->
  1612:       (*
  1613:       print_endline ("Handling init: " ^ string_of_bexe syms.dfns 0 exe);
  1614:       *)
  1615:       heavily_inline_bbdcl syms (uses,child_map,bbdfns) (callee::excludes) callee;
  1616:       let id,parent,sr,entry = Hashtbl.find bbdfns callee in
  1617:       begin match entry with
  1618:       | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
  1619:         if
  1620:           mem `Inlining_complete props &&
  1621:           not (mem `NoInline props) &&
  1622:           (
  1623:             mem `Inline props ||
  1624:             length exes <= syms.compiler_options.max_inline_length
  1625:           ) &&
  1626:           (
  1627:             (* only inline a recursive call to a child *)
  1628:             not (Flx_call.is_recursive_call uses caller callee) ||
  1629:             is_child child_map caller callee
  1630:           )
  1631:         then
  1632:           begin
  1633:             let vid,vparent,vsr,ventry = Hashtbl.find bbdfns i in
  1634:             begin match ventry with
  1635:             | `BBDCL_tmp (vs,t) ->
  1636:               (*
  1637:               print_endline ("Downgrading temporary .." ^ si i);
  1638:               *)
  1639:               (* should this be a VAR or a VAL? *)
  1640:               Hashtbl.replace bbdfns i (vid,vparent,vsr,`BBDCL_var (vs,t))
  1641:             | _ -> ()
  1642:             end;
  1643:             let xs =
  1644:                inline_function syms (uses,child_map,bbdfns) caller caller_vs callee ts a i
  1645:             in
  1646:               let xs = hic callee xs in
  1647:               exes' := rev xs @ !exes'
  1648:           end
  1649:         else
  1650:           exes' := exe :: !exes'
  1651:       | _ -> exes' := exe :: !exes'
  1652:       end
  1653: 
  1654:     | `BEXE_fun_return (sr,(`BEXPR_apply((`BEXPR_closure(callee,ts),_),a),_))
  1655:     (* -> assert false .. seems this still happens ..*)
  1656:     | `BEXE_fun_return (sr,(`BEXPR_apply_direct (callee,ts,a),_))
  1657:       when not (mem callee excludes)  ->
  1658:       (*
  1659:       print_endline ("Handling return: " ^ string_of_bexe syms.dfns 0 exe);
  1660:       *)
  1661:       heavily_inline_bbdcl syms (uses,child_map,bbdfns) (callee::excludes) callee;
  1662:       let id,parent,sr,entry = Hashtbl.find bbdfns callee in
  1663:       begin match entry with
  1664:       | `BBDCL_function (props,vs,(ps,traint),ret,exes) ->
  1665:         if
  1666:           not (mem `NoInline props) &&
  1667:           (
  1668:               mem `Inline props ||
  1669:               length exes <= syms.compiler_options.max_inline_length
  1670:           ) &&
  1671:           (
  1672:             (* only inline a recursive call to a child *)
  1673:             not (Flx_call.is_recursive_call uses caller callee) ||
  1674:             is_child child_map caller callee
  1675:           )
  1676:         then begin
  1677:           (*
  1678:           heavily_inline_bbdcl syms (uses,child_map,bbdfns) (callee::excludes) callee;
  1679:           *)
  1680:           if inlining_complete bbdfns callee then
  1681:             let xs =
  1682:                (*
  1683:                print_endline ("Tail apply: " ^ string_of_bexe syms.dfns 0 exe);
  1684:                *)
  1685:                inline_tail_apply syms (uses,child_map,bbdfns) caller caller_vs callee ts a
  1686:             in
  1687:               let xs = hic callee xs in
  1688:               exes' := rev xs @ !exes'
  1689:           else
  1690:             exes' := exe :: !exes'
  1691:         end else
  1692:           exes' := exe :: !exes'
  1693:       | _ -> exes' := exe :: !exes'
  1694:       end
  1695:     | _ -> exes' := exe :: !exes'
  1696:     )
  1697:     xs
  1698:   )
  1699:   exes
  1700:   ;
  1701:   rev !exes'
  1702: 
  1703: 
  1704: and fold_vars syms (uses,child_map,bbdfns) i ps exes =
  1705:   let pset = fold_left (fun s (_,(i,_))-> IntSet.add i s) IntSet.empty ps in
  1706:   let kids = find_children child_map i in
  1707:   let id,_,_,_ = Hashtbl.find bbdfns i in
  1708:   (*
  1709:   print_endline ("\nFOLDing " ^ id ^ "<" ^ si i ^">");
  1710:   print_endline ("Kids = " ^ catmap ", " si kids);
  1711:   *)
  1712:   let descend = descendants child_map i in
  1713:   (*
  1714:   print_endline ("Descendants are " ^ string_of_intset descend);
  1715:   *)
  1716:   let locls = locals child_map uses i in
  1717:   (*
  1718:   print_endline ("Locals of " ^ si i ^ " are " ^ string_of_intset locls);
  1719:   print_endline "INPUT Code is";
  1720:   iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
  1721:   *)
  1722: 
  1723:   let elim_pass exes =
  1724:     let count = ref 0 in
  1725:     let rec find_tassign inexes outexes =
  1726:       match inexes with
  1727:       | [] -> rev outexes
  1728:       | ((
  1729:         `BEXE_init (_,j,y)
  1730:         | `BEXE_assign (_, (`BEXPR_name (j,_),_),y)
  1731:       ) as x) :: t  when IntSet.mem j locls ->
  1732: 
  1733:         let id,_,_,_ = Hashtbl.find bbdfns j in
  1734:         (*
  1735:         print_endline ("CONSIDERING VARIABLE " ^ id ^ "<" ^ si j ^ "> -> " ^ sbe syms.dfns y);
  1736:         *)
  1737:         (* does uses include initialisations or not ..?? *)
  1738: 
  1739:         (* check if the variable is used by any descendants *)
  1740:         let nlocal_uses =
  1741:           IntSet.fold
  1742:           (fun child u ->
  1743:              let luses = Flx_call.use_closure uses child in
  1744:              u || IntSet.mem j luses
  1745:           )
  1746:           descend
  1747:           false
  1748:         in
  1749:         if nlocal_uses then begin
  1750:           (*
  1751:           print_endline "VARIABLE USED NONLOCALLY";
  1752:           *)
  1753:           find_tassign t (x::outexes)
  1754:         end else
  1755: 
  1756:         (* count all local uses of the variable: there are no others *)
  1757:         let usecnt =
  1758:           let luses = try Hashtbl.find uses i with Not_found -> [] in
  1759:           fold_left (fun u (k,sr) -> if k = j then u+1 else u) 0 luses
  1760:          in
  1761:         (*
  1762:         print_endline ("Use count = " ^ si usecnt);
  1763:         *)
  1764:         let setcnt = ref (if IntSet.mem j pset then 2 else 1) in
  1765:         let sets exe =
  1766:           match exe with
  1767:            | `BEXE_init (_,k,_) when j = k -> incr setcnt
  1768:            | _ -> ()
  1769:         in
  1770:         iter sets t; iter sets outexes;
  1771:         (*
  1772:         print_endline ("Set count = " ^ si !setcnt);
  1773:         *)
  1774:         let yuses = Flx_call.expr_uses syms descend uses pset y in
  1775:         let delete_var () =
  1776:           let id,_,_,_ = Hashtbl.find bbdfns j in
  1777:           if syms.compiler_options.print_flag then
  1778:             print_endline ("ELIMINATING VARIABLE " ^ id ^ "<" ^ si j ^ "> -> " ^ sbe syms.dfns y);
  1779: 
  1780:           (* remove the variable *)
  1781:           Hashtbl.remove bbdfns j;
  1782:           remove_child child_map i j;
  1783:           remove_uses uses i j;
  1784:           incr count
  1785:         in
  1786:         let isvar =
  1787:           match Hashtbl.find bbdfns j with
  1788:           | _,_,_,(`BBDCL_var _ | `BBDCL_tmp _) -> true
  1789:           | _,_,_,`BBDCL_val _ -> false
  1790:           | _ -> assert false
  1791:         in
  1792: 
  1793:         (* Cannot do anything with variables or multiply assigned values
  1794:           so skip to next instruction -- this is a tail-recursive call
  1795:         *)
  1796:         if isvar or !setcnt > 1 then begin
  1797:           (*
  1798:           print_endline "IS VAR or SETCNT > 1";
  1799:           *)
  1800:           find_tassign t (x::outexes)
  1801: 
  1802:         (* otherwise it is a value and it is set at most once *)
  1803: 
  1804:         (* it is not used anywhere (except the init) *)
  1805:         end else if usecnt = 1 then begin
  1806:           if syms.compiler_options.print_flag then
  1807:           print_endline "WARNING: unused variable found ..";
  1808:           delete_var();
  1809:           find_tassign t outexes
  1810: 
  1811:         (* OK, it is used at least once *)
  1812:         end else
  1813:         (* count elision of the init as 1 *)
  1814:         let rplcnt = ref 1 in
  1815:         let subi,rplimit =
  1816:           match y with
  1817:           | `BEXPR_tuple ys,_ ->
  1818:             (*
  1819:             print_endline "Tuple init found";
  1820:             *)
  1821:             let rec subi j ys e =
  1822:               match map_tbexpr ident (subi j ys) ident e with
  1823:               | `BEXPR_get_n (k, (`BEXPR_name(i,_),_) ),_
  1824:                 when j = i ->
  1825:                 (*
  1826:                 print_endline ("Replacing " ^ sbe syms.dfns e);
  1827:                 *)
  1828:                 incr rplcnt; nth ys k
  1829:               | x -> x
  1830:             in subi j ys, length ys + 1
  1831:           | _ ->
  1832:             let rec subi j y e =
  1833:               match map_tbexpr ident (subi j y) ident e with
  1834:               | `BEXPR_name (i,_),_ when j = i -> incr rplcnt; y
  1835:               | x -> x
  1836:             in subi j y, 2 (* take init into account *)
  1837:         in
  1838:         let elimi exe =
  1839:           map_bexe ident subi ident ident ident exe
  1840:         in
  1841:         let subs = ref true in
  1842:         let elim exes = map
  1843:           (fun exe ->
  1844:           (*
  1845:           print_endline ("In Exe = " ^ string_of_bexe syms.dfns 2 exe);
  1846:           *)
  1847:           if !subs then
  1848:           match exe with
  1849:           | `BEXE_axiom_check _ -> assert false
  1850: 
  1851:           (* terminate substitution, return unmodified instr *)
  1852:           | `BEXE_goto _
  1853:           | `BEXE_proc_return _
  1854:           | `BEXE_label _
  1855:              -> subs:= false; exe
  1856: 
  1857:           (* return unmodified instr *)
  1858:           | `BEXE_begin
  1859:           | `BEXE_end
  1860:           | `BEXE_nop _
  1861:           | `BEXE_code _
  1862:           | `BEXE_nonreturn_code _
  1863:           | `BEXE_comment _
  1864:           | `BEXE_halt _
  1865:              -> exe
  1866: 
  1867:           (* conditional, check if y depends on init (tail rec) *)
  1868: 
  1869:           | `BEXE_assign (_,(`BEXPR_name (k,_),_),_)
  1870:           | `BEXE_svc (_,k)
  1871:           | `BEXE_init (_,k,_) ->
  1872:              subs := not (IntSet.mem k yuses);
  1873:              elimi exe
  1874: 
  1875:           (* return modified instr *)
  1876:           | `BEXE_ifgoto _
  1877:           | `BEXE_ifnotgoto _
  1878:           | `BEXE_assert _
  1879:           | `BEXE_assert2 _
  1880:              -> elimi exe
  1881: 
  1882:           (* terminate substitution, return modified instr *)
  1883:           | `BEXE_apply_ctor _
  1884:           | `BEXE_apply_ctor_stack _
  1885:           | `BEXE_assign _
  1886:           | `BEXE_fun_return _
  1887:           | `BEXE_jump _
  1888:           | `BEXE_jump_direct _
  1889:           | `BEXE_loop _
  1890:           | `BEXE_call_prim _
  1891:           | `BEXE_call _
  1892:           | `BEXE_call_direct _
  1893:           | `BEXE_call_method_direct _
  1894:           | `BEXE_call_method_stack _
  1895:           | `BEXE_call_stack _
  1896:              -> subs := false; elimi exe
  1897:           else exe
  1898:           )
  1899:           exes
  1900:         in
  1901:         let t' = elim t in
  1902:         if !rplcnt > rplimit then
  1903:           begin
  1904:             if syms.compiler_options.print_flag then
  1905:             print_endline (
  1906:               "Warning: replacement count " ^
  1907:               si !rplcnt ^
  1908:               " exceeds replacement limit " ^
  1909:               si rplimit
  1910:             );
  1911:             find_tassign t (x::outexes)
  1912:           end
  1913:         else if !rplcnt <> usecnt then
  1914:           begin
  1915:             if syms.compiler_options.print_flag then
  1916:             print_endline (
  1917:               "Warning: replacement count " ^
  1918:               si !rplcnt ^
  1919:               " not equal to usage count " ^
  1920:               si usecnt
  1921:             );
  1922:             find_tassign t (x::outexes)
  1923:           end
  1924:         else
  1925:           begin
  1926:             delete_var();
  1927:             find_tassign t' outexes
  1928:           end
  1929: 
  1930:       | h::t -> find_tassign t (h::outexes)
  1931:     in
  1932:     !count,find_tassign exes []
  1933:   in
  1934:   let master_count = ref 0 in
  1935:   let iters = ref 0 in
  1936:   let rec elim exes =
  1937:     let count,exes = elim_pass exes in
  1938:     incr iters;
  1939:     master_count := !master_count + count;
  1940:     if count > 0 then elim exes else exes
  1941:   in
  1942:   let exes = elim exes in
  1943: 
  1944:   (*
  1945:   if syms.compiler_options.print_flag then
  1946:   *)
  1947:   if !master_count > 0 then begin
  1948:     if syms.compiler_options.print_flag then
  1949:     print_endline ("Removed " ^ si !master_count ^" variables in " ^ si !iters ^ " passes");
  1950:     (*
  1951:     print_endline "OUTPUT Code is";
  1952:     iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
  1953:     *)
  1954:   end
  1955:   ;
  1956:   exes
  1957: 
  1958: and remove_unused_children syms (uses,child_map,bbdfns) i =
  1959:   let desc = descendants child_map i in
  1960:   if desc <> IntSet.empty then begin
  1961:     (* all the descendants of a routine, excluding self *)
  1962:     (*
  1963:     print_endline "CANDIDATE FOR CHILD REMOVAL";
  1964:     print_function syms.dfns bbdfns i;
  1965:     print_endline ("Descendants of " ^ si i ^ " =" ^ IntSet.fold (fun j s -> s ^ " " ^ si j) desc "");
  1966:     IntSet.iter (fun i-> print_function syms.dfns bbdfns i) desc;
  1967:     *)
  1968: 
  1969: 
  1970:     (* everything used by this routine directly or indirectly *)
  1971:     let used = Flx_call.use_closure uses i in
  1972: 
  1973:     (*
  1974:     print_endline ("Usage closure of " ^ si i ^ " =" ^ IntSet.fold (fun j s -> s ^ " " ^ si j) used "");
  1975:     *)
  1976:     (* any desendants not used by this routine *)
  1977:     let unused_descendants = IntSet.diff desc used in
  1978: 
  1979:     (* remove the item *)
  1980:     IntSet.iter
  1981:     (fun i ->
  1982:       begin
  1983:         try
  1984:           (* any parent disowns the child *)
  1985:           match Hashtbl.find bbdfns i with
  1986:           | _,Some parent,_,_ -> remove_child child_map parent i
  1987:           | _ -> ()
  1988:         with Not_found -> ()
  1989:       end
  1990:       ;
  1991: 
  1992:       (* remove from symbol table, child map, and usage map *)
  1993:       Hashtbl.remove bbdfns i;
  1994:       Hashtbl.remove child_map i;
  1995:       Hashtbl.remove uses i;
  1996:       (*
  1997:       print_endline ("REMOVED SYMBOL " ^ qualified_name_of_index syms.dfns i)
  1998:       *)
  1999:     )
  2000:     unused_descendants
  2001:   end
  2002: 
  2003: and check_reductions syms exes =
  2004:   let changed = ref true in
  2005:   let count = ref 10 in
  2006:   let exes = ref exes in
  2007: 
  2008:   while !count > 0 && !changed do
  2009:     changed := false;
  2010:     iter (fun (id,bvs,bps,e1,e2) ->
  2011:       (* print_endline ("Check reduction rule " ^ id); *)
  2012:       let tvars = map (fun (tvid, tvidx) -> tvidx) bvs in
  2013:       let evars = map (fun (eid, (eidx, etyp)) -> eidx) bps in
  2014:       let ematch e =
  2015:         (* print_endline ("Matching " ^ sbe syms.dfns e ^ " with " ^ sbe syms.dfns e1); *)
  2016:         match expr_maybe_matches syms.dfns tvars evars e1 e with
  2017:         | Some (tmgu,emgu) ->
  2018:           changed := true;
  2019:           (*
  2020:           print_endline ("FOUND A MATCH, candidate " ^ sbe syms.dfns e^" with reduced LHS " ^ sbe syms.dfns e1);
  2021:           print_endline ("EMGU=" ^catmap ", " (fun (i,e')-> si i ^ " --> " ^ sbe syms.dfns e') emgu);
  2022:           print_endline ("TMGU=" ^catmap ", " (fun (i,t')-> si i ^ " --> " ^ sbt syms.dfns t') tmgu);
  2023:           *)
  2024:           let e = fold_left (fun e (i,e') -> expr_term_subst e i e') e2 emgu in
  2025:           let rec s e = map_tbexpr ident s (list_subst tmgu) e in
  2026:           let e = s e in
  2027:           (*
  2028:           print_endline ("RESULT OF SUBSTITUTION into RHS: " ^ sbe syms.dfns e2 ^ " is " ^ sbe syms.dfns e);
  2029:           *)
  2030:           e
  2031:         | None -> e
  2032:       in
  2033:       exes :=
  2034:         map
  2035:         (fun bexe ->
  2036:           map_bexe ident ematch ident ident ident bexe
  2037:         )
  2038:         !exes
  2039:       ;
  2040:     )
  2041:     syms.reductions
  2042:     ;
  2043:     decr count
  2044:   done
  2045:   ;
  2046:   !exes
  2047: 
  2048: and heavily_inline_bbdcl syms (uses,child_map,bbdfns) excludes i =
  2049:   let specs =
  2050:     try Some (Hashtbl.find bbdfns i)
  2051:     with Not_found -> None
  2052:   in
  2053:   match specs with None -> () | Some spec ->
  2054:   match spec with
  2055:   | id,parent,sr,`BBDCL_procedure (props,vs,(ps,traint),exes) ->
  2056:     if not (mem `Inlining_started props) then begin
  2057:       let props = `Inlining_started :: props in
  2058:       let data = id,parent,sr,`BBDCL_procedure (props,vs,(ps,traint),exes) in
  2059:       Hashtbl.replace bbdfns i data;
  2060: 
  2061:       (* inline into all children first *)
  2062:       let children = find_children child_map i in
  2063:       iter (fun i-> heavily_inline_bbdcl syms (uses, child_map, bbdfns) excludes i) children;
  2064: 
  2065:       let xcls = Flx_tailit.exes_get_xclosures syms exes in
  2066:       IntSet.iter (fun i-> heavily_inline_bbdcl syms (uses, child_map, bbdfns) excludes i) xcls;
  2067: 
  2068:       (*
  2069:       print_endline ("HIB: Examining procedure " ^ id ^ "<"^ si i ^ "> for inlinable calls");
  2070:       print_endline ("Input:\n" ^ catmap "\n" (string_of_bexe syms.dfns 0) exes);
  2071:       *)
  2072:       recal_exes_usage syms uses sr i ps exes;
  2073:       let exes = fold_vars syms (uses,child_map,bbdfns) i ps exes in
  2074:       recal_exes_usage syms uses sr i ps exes;
  2075:       let exes = heavy_inline_calls syms (uses,child_map,bbdfns) vs i excludes exes in
  2076:       (*
  2077:       print_endline (id ^ " After inlining calls:\n" ^ catmap "\n" (string_of_bexe syms.dfns 0) exes);
  2078:       *)
  2079:       recal_exes_usage syms uses sr i ps exes;
  2080:       let exes = Flx_tailit.tailit syms (uses,child_map,bbdfns) i sr ps vs exes in
  2081:       (*
  2082:       print_endline (id ^ " After tailing:\n" ^ catmap "\n" (string_of_bexe syms.dfns 0) exes);
  2083:       *)
  2084: 
  2085:       recal_exes_usage syms uses sr i ps exes;
  2086:       let exes = fold_vars syms (uses,child_map,bbdfns) i ps exes in
  2087:       recal_exes_usage syms uses sr i ps exes;
  2088:       let exes = check_reductions syms exes in
  2089:       let exes = Flx_cflow.chain_gotos syms exes in
  2090:       let props = `Inlining_complete :: props in
  2091:       let data = id,parent,sr,`BBDCL_procedure (props,vs,(ps,traint),exes) in
  2092:       Hashtbl.replace bbdfns i data;
  2093:       recal_exes_usage syms uses sr i ps exes;
  2094:       remove_unused_children syms (uses,child_map,bbdfns) i;
  2095:       (*
  2096:       print_endline ("DONE Examining procedure " ^ id ^ "<"^ si i ^ "> for inlinable calls");
  2097:       print_endline ("OPTIMISED PROCEDURE BODY: " ^ id ^ " :\n" ^ catmap "\n" (string_of_bexe syms.dfns 2) exes);
  2098:       *)
  2099:     end
  2100: 
  2101:   | id,parent,sr,`BBDCL_function (props,vs,(ps,traint),ret,exes) ->
  2102:     if not (mem `Inlining_started props) then begin
  2103:       let props = `Inlining_started :: props in
  2104:       let data = id,parent,sr,`BBDCL_function (props,vs,(ps,traint),ret,exes) in
  2105:       Hashtbl.replace bbdfns i data;
  2106: 
  2107:       (* inline into all children first *)
  2108:       let children = find_children child_map i in
  2109:       iter (fun i-> heavily_inline_bbdcl syms (uses, child_map, bbdfns) excludes i) children;
  2110: 
  2111:       let xcls = Flx_tailit.exes_get_xclosures syms exes in
  2112:       IntSet.iter (fun i-> heavily_inline_bbdcl syms (uses, child_map, bbdfns) excludes i) xcls;
  2113: 
  2114:       (*
  2115:       print_endline ("HIB:Examining function " ^ id ^"<" ^ si i ^ "> for inlinable calls");
  2116:       print_endline (id ^ " Input:\n" ^ catmap "\n" (string_of_bexe syms.dfns 0) exes);
  2117:       *)
  2118:       recal_exes_usage syms uses sr i ps exes;
  2119:       let exes = fold_vars syms (uses,child_map,bbdfns) i ps exes in
  2120:       recal_exes_usage syms uses sr i ps exes;
  2121:       let exes = heavy_inline_calls syms (uses,child_map,bbdfns) vs i excludes exes in
  2122:       (*
  2123:       print_endline (id ^ " After inlining calls:\n" ^ catmap "\n" (string_of_bexe syms.dfns 0) exes);
  2124:       *)
  2125:       (*
  2126:       print_endline ("Tailing " ^ si i);
  2127:       *)
  2128:       recal_exes_usage syms uses sr i ps exes;
  2129:       let exes = Flx_tailit.tailit syms (uses,child_map,bbdfns) i sr ps vs exes in
  2130:       (*
  2131:       print_endline (id ^ " After tailing:\n" ^ catmap "\n" (string_of_bexe syms.dfns 0) exes);
  2132:       *)
  2133: 
  2134:       (*
  2135:       print_endline (id^ " After tailing(2):\n" ^ catmap "\n" (string_of_bexe syms.dfns 0) exes);
  2136:       *)
  2137:       recal_exes_usage syms uses sr i ps exes;
  2138:       let exes = fold_vars syms (uses,child_map,bbdfns) i ps exes in
  2139:       recal_exes_usage syms uses sr i ps exes;
  2140:       let exes = check_reductions syms exes in
  2141:       let exes = Flx_cflow.chain_gotos syms exes in
  2142:       let props = `Inlining_complete :: props in
  2143:       let data = id,parent,sr,`BBDCL_function (props,vs,(ps,traint),ret,exes) in
  2144:       Hashtbl.replace bbdfns i data;
  2145:       recal_exes_usage syms uses sr i ps exes;
  2146:       remove_unused_children syms (uses,child_map,bbdfns) i;
  2147:       (*
  2148:       print_endline ("DONE Examining function " ^ id ^"<" ^ si i ^ "> for inlinable calls");
  2149:       print_endline ("OPTIMISED FUNCTION BODY: " ^ id ^ " :\n" ^ catmap "\n" (string_of_bexe syms.dfns 2) exes);
  2150:       *)
  2151:     end
  2152:   | _ -> ()
  2153: 
  2154: let heavy_inlining syms
  2155:   (child_map,bbdfns)
  2156: =
  2157:   let used = ref (!(syms.roots)) in
  2158:   let (uses,usedby) = Flx_call.call_data syms bbdfns in
  2159: 
  2160:   while not (IntSet.is_empty !used) do
  2161:     let i = IntSet.choose !used in
  2162:     used := IntSet.remove i !used;
  2163:     heavily_inline_bbdcl syms (uses,child_map,bbdfns) [i] i
  2164:   done;
  2165: 
  2166: (* NOTES: this algorithm ONLY WORKS if inlining is attempted
  2167: in the corect order. Attempting to inline into children
  2168: before parents, when they're mutually recursive, spawns
  2169: clones infinitely, because we end up cloning a function
  2170: on the exclusion list, but not adding the clone to it.
  2171: 
  2172: 
  2173: NOTE!!!! THIS SHOULD BE FIXED NOW. WE NO LONGER
  2174: PERMIT INLINING RECURSIVE FUNCTIONS UNLESS THE CALL
  2175: IS TO A CHILD. A CALL TO SELF, PARENT OR SIBLING NEVER
  2176: DOES INLINING .. AND THERE ARE NO OTHER CASES.
  2177: 
  2178: INLINING KIDS IS MANDATORY FOR TAIL RECURSION OPTIMISATION.
  2179: 
  2180: So we end up recursing into the clone, and inlining
  2181: into it, which spawns more clones which are not
  2182: excluded, and haven't been inlined into yet.
  2183: 
  2184: This needs to be fixed so the algorithm is proven
  2185: to terminate and also be complete.
  2186: 
  2187: What we need (and is NOT implemented) is something like this:
  2188: 
  2189: Cloning nested functions is should not be needed in general.
  2190: If we proceed from leaves towards the root, we can eliminate
  2191: from each function any nested children, by simply inlining
  2192: them. So only variable children need cloning.
  2193: 
  2194: Two things stop this working:
  2195: 
  2196: (a) non-inline functions and
  2197: (b) recursion.
  2198: 
  2199: The current algorithm has been hacked to only handle the
  2200: call graph from the roots. It used to consider the useage
  2201: closure, however that started to fail when I added
  2202: 'pre-assigned' slot numbers (AST_index). Doing that meant
  2203: the natural order of the set wasn't a topological sort
  2204: of the parent-child order.
  2205: 
  2206: Unfortunately, the remaining recursive descent doesn't
  2207: proceed into noinline functions. Although these shouldn't
  2208: be inlined into their caller, that doesn't mean functions
  2209: shouldn't be inlined into them. Iterating over the usage
  2210: closure ensured noinline functions would still be inlined
  2211: into.
  2212: 
  2213: Recursive functions are a bit different: they currently
  2214: allow inlining, with a recursion stopper preventing
  2215: infinite recursion.
  2216: 
  2217: Unfortunately with a double nesting like this:
  2218: 
  2219:   fun f() { fun g() { fun h() { f(); } h(); } g(); }
  2220: 
  2221: trying to inline g into f causes h to be cloned.
  2222: But trying to inline f into the clone of h retriggers
  2223: the descent, causing the clone to be recloned, and
  2224: the recursion stopper doesn't prevent this, since it
  2225: isn't the same routine being inlined twice (just a clone
  2226: of it ..)
  2227: 
  2228: The thing is.. we HAVE to inline the original routine
  2229: AND the clone for completeness, since both may be
  2230: called independently, so even if we could clone the
  2231: recursion stoppers, it wouldn't work.
  2232: 
  2233: The only solution I can think of is to guarrantee that
  2234: you can only clone a routine that is inlined into
  2235: already (as fas as possible) so that no attempt will
  2236: be made to inline into the clone either.
  2237: --------------------------------------------------------------
  2238: Hum.... When I inline A -> B -> C -> A (all kid inlines) the
  2239: inline of A into C is done first. This creates clones B' and C'.
  2240: When we rescan the code to be put into C, we would try to
  2241: inline B' into it, and C' into that .. but C' is a cloned sibling
  2242: of C, and not the same function. So we try to inline into C',
  2243: and inlining A is allowed there .. which causes an infinite
  2244: recursion.
  2245: 
  2246: *)
End ocaml section to src/flx_inline.ml[1]