1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Pierre Chambart, OCamlPro *) 6(* Mark Shinwell and Leo White, Jane Street Europe *) 7(* *) 8(* Copyright 2013--2016 OCamlPro SAS *) 9(* Copyright 2014--2016 Jane Street Group LLC *) 10(* *) 11(* All rights reserved. This file is distributed under the terms of *) 12(* the GNU Lesser General Public License version 2.1, with the *) 13(* special exception on linking described in the file LICENSE. *) 14(* *) 15(**************************************************************************) 16 17[@@@ocaml.warning "+a-4-9-30-40-41-42"] 18 19module Closure_stack = struct 20 type t = node list 21 22 and node = 23 | Closure of Closure_id.t * Debuginfo.t 24 | Call of Closure_id.t * Debuginfo.t 25 | Inlined 26 | Specialised of Closure_id.Set.t 27 28 let create () = [] 29 30 let note_entering_closure t ~closure_id ~dbg = 31 if not !Clflags.inlining_report then t 32 else 33 match t with 34 | [] | (Closure _ | Inlined | Specialised _) :: _-> 35 (Closure (closure_id, dbg)) :: t 36 | (Call _) :: _ -> 37 Misc.fatal_errorf "note_entering_closure: unexpected Call node" 38 39 (* CR-someday lwhite: since calls do not have a unique id it is possible 40 some calls will end up sharing nodes. *) 41 let note_entering_call t ~closure_id ~dbg = 42 if not !Clflags.inlining_report then t 43 else 44 match t with 45 | [] | (Closure _ | Inlined | Specialised _) :: _ -> 46 (Call (closure_id, dbg)) :: t 47 | (Call _) :: _ -> 48 Misc.fatal_errorf "note_entering_call: unexpected Call node" 49 50 let note_entering_inlined t = 51 if not !Clflags.inlining_report then t 52 else 53 match t with 54 | [] | (Closure _ | Inlined | Specialised _) :: _-> 55 Misc.fatal_errorf "note_entering_inlined: missing Call node" 56 | (Call _) :: _ -> Inlined :: t 57 58 let note_entering_specialised t ~closure_ids = 59 if not !Clflags.inlining_report then t 60 else 61 match t with 62 | [] | (Closure _ | Inlined | Specialised _) :: _ -> 63 Misc.fatal_errorf "note_entering_specialised: missing Call node" 64 | (Call _) :: _ -> Specialised closure_ids :: t 65 66end 67 68let log 69 : (Closure_stack.t * Inlining_stats_types.Decision.t) list ref 70 = ref [] 71 72let record_decision decision ~closure_stack = 73 if !Clflags.inlining_report then begin 74 match closure_stack with 75 | [] 76 | Closure_stack.Closure _ :: _ 77 | Closure_stack.Inlined :: _ 78 | Closure_stack.Specialised _ :: _ -> 79 Misc.fatal_errorf "record_decision: missing Call node" 80 | Closure_stack.Call _ :: _ -> 81 log := (closure_stack, decision) :: !log 82 end 83 84module Inlining_report = struct 85 86 module Place = struct 87 type kind = 88 | Closure 89 | Call 90 91 type t = Debuginfo.t * Closure_id.t * kind 92 93 let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) = 94 let c = Debuginfo.compare d1 d2 in 95 if c <> 0 then c else 96 let c = Closure_id.compare cl1 cl2 in 97 if c <> 0 then c else 98 match k1, k2 with 99 | Closure, Closure -> 0 100 | Call, Call -> 0 101 | Closure, Call -> 1 102 | Call, Closure -> -1 103 end 104 105 module Place_map = Map.Make(Place) 106 107 type t = node Place_map.t 108 109 and node = 110 | Closure of t 111 | Call of call 112 113 and call = 114 { decision: Inlining_stats_types.Decision.t option; 115 inlined: t option; 116 specialised: t option; } 117 118 let empty_call = 119 { decision = None; 120 inlined = None; 121 specialised = None; } 122 123 (* Prevented or unchanged decisions may be overridden by a later look at the 124 same call. Other decisions may also be "overridden" because calls are not 125 uniquely identified. *) 126 let add_call_decision call (decision : Inlining_stats_types.Decision.t) = 127 match call.decision, decision with 128 | None, _ -> { call with decision = Some decision } 129 | Some _, Prevented _ -> call 130 | Some (Prevented _), _ -> { call with decision = Some decision } 131 | Some (Specialised _), _ -> call 132 | Some _, Specialised _ -> { call with decision = Some decision } 133 | Some (Inlined _), _ -> call 134 | Some _, Inlined _ -> { call with decision = Some decision } 135 | Some Unchanged _, Unchanged _ -> call 136 137 let add_decision t (stack, decision) = 138 let rec loop t : Closure_stack.t -> _ = function 139 | Closure(cl, dbg) :: rest -> 140 let key : Place.t = (dbg, cl, Closure) in 141 let v = 142 try 143 match Place_map.find key t with 144 | Closure v -> v 145 | Call _ -> assert false 146 with Not_found -> Place_map.empty 147 in 148 let v = loop v rest in 149 Place_map.add key (Closure v) t 150 | Call(cl, dbg) :: rest -> 151 let key : Place.t = (dbg, cl, Call) in 152 let v = 153 try 154 match Place_map.find key t with 155 | Call v -> v 156 | Closure _ -> assert false 157 with Not_found -> empty_call 158 in 159 let v = 160 match rest with 161 | [] -> add_call_decision v decision 162 | Inlined :: rest -> 163 let inlined = 164 match v.inlined with 165 | None -> Place_map.empty 166 | Some inlined -> inlined 167 in 168 let inlined = loop inlined rest in 169 { v with inlined = Some inlined } 170 | Specialised _ :: rest -> 171 let specialised = 172 match v.specialised with 173 | None -> Place_map.empty 174 | Some specialised -> specialised 175 in 176 let specialised = loop specialised rest in 177 { v with specialised = Some specialised } 178 | Call _ :: _ -> assert false 179 | Closure _ :: _ -> assert false 180 in 181 Place_map.add key (Call v) t 182 | [] -> assert false 183 | Inlined :: _ -> assert false 184 | Specialised _ :: _ -> assert false 185 in 186 loop t (List.rev stack) 187 188 let build log = 189 List.fold_left add_decision Place_map.empty log 190 191 let print_stars ppf n = 192 let s = String.make n '*' in 193 Format.fprintf ppf "%s" s 194 195 let rec print ~depth ppf t = 196 Place_map.iter (fun (dbg, cl, _) v -> 197 match v with 198 | Closure t -> 199 Format.fprintf ppf "@[<h>%a Definition of %a%s@]@." 200 print_stars (depth + 1) 201 Closure_id.print cl 202 (Debuginfo.to_string dbg); 203 print ppf ~depth:(depth + 1) t; 204 if depth = 0 then Format.pp_print_newline ppf () 205 | Call c -> 206 match c.decision with 207 | None -> 208 Misc.fatal_error "Inlining_report.print: missing call decision" 209 | Some decision -> 210 Format.pp_open_vbox ppf (depth + 2); 211 Format.fprintf ppf "@[<h>%a Application of %a%s@]@;@;@[%a@]" 212 print_stars (depth + 1) 213 Closure_id.print cl 214 (Debuginfo.to_string dbg) 215 Inlining_stats_types.Decision.summary decision; 216 Format.pp_close_box ppf (); 217 Format.pp_print_newline ppf (); 218 Format.pp_print_newline ppf (); 219 Inlining_stats_types.Decision.calculation ~depth:(depth + 1) 220 ppf decision; 221 begin 222 match c.specialised with 223 | None -> () 224 | Some specialised -> 225 print ppf ~depth:(depth + 1) specialised 226 end; 227 begin 228 match c.inlined with 229 | None -> () 230 | Some inlined -> 231 print ppf ~depth:(depth + 1) inlined 232 end; 233 if depth = 0 then Format.pp_print_newline ppf ()) 234 t 235 236 let print ppf t = print ~depth:0 ppf t 237 238end 239 240let really_save_then_forget_decisions ~output_prefix = 241 let report = Inlining_report.build !log in 242 let out_channel = open_out (output_prefix ^ ".inlining.org") in 243 let ppf = Format.formatter_of_out_channel out_channel in 244 Inlining_report.print ppf report; 245 close_out out_channel; 246 log := [] 247 248let save_then_forget_decisions ~output_prefix = 249 if !Clflags.inlining_report then begin 250 really_save_then_forget_decisions ~output_prefix 251 end 252