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.
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:
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: *)