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