package memtrace_viewer

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file hot_paths.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
open! Core
open Memtrace_viewer_common

module Fragment_queue : sig
  type t

  val create : unit -> t
  val add_exn : t -> Data.Fragment.t -> unit
  val pop_max_allocations : t -> Data.Fragment.t option
  val remove : t -> Data.Fragment.t -> unit
end = struct
  module Item = struct
    type t =
      { fragment : Data.Fragment.t
      ; allocations : Byte_units.t
      }

    let of_fragment fragment =
      let allocations = Data.Entry.allocations (Data.Fragment.entry fragment) in
      { fragment; allocations }
    ;;

    let compare t1 t2 =
      (* Higher total count = higher priority (thus < because min heap) *)
      Byte_units.compare t2.allocations t1.allocations
    ;;
  end

  module Id = Data.Fragment.Id

  type t =
    { queue : Item.t Pairing_heap.t
    ; elts : Item.t Pairing_heap.Elt.t Id.Table.t
    }

  let create () =
    let queue = Pairing_heap.create ~cmp:Item.compare () in
    let elts = Id.Table.create () in
    { queue; elts }
  ;;

  let add_exn { queue; elts } fragment =
    let elt = Pairing_heap.add_removable queue (fragment |> Item.of_fragment) in
    Hashtbl.add_exn elts ~key:(Data.Fragment.id fragment) ~data:elt
  ;;

  let pop_max_allocations { queue; elts } =
    let max = Pairing_heap.pop queue in
    Option.map max ~f:(fun { fragment; allocations = _ } ->
      Hashtbl.remove elts (Data.Fragment.id fragment);
      fragment)
  ;;

  let remove { queue; elts } fragment =
    let id = Data.Fragment.id fragment in
    let elt = Hashtbl.find_and_remove elts id in
    Option.iter ~f:(Pairing_heap.remove queue) elt
  ;;
end

let hot_paths trie =
  let queue = Fragment_queue.create () in
  let rec enqueue_all_representatives node =
    if (not (Data.Fragment.is_empty node))
    && Data.Fragment.same node (Data.Fragment.representative node)
    then Fragment_queue.add_exn queue node;
    List.iter
      (Data.Fragment.one_frame_extensions node ~orient:Callees)
      ~f:(fun (_, child) -> enqueue_all_representatives child)
  in
  enqueue_all_representatives (Data.Fragment_trie.empty_fragment trie);
  let rec loop ~hot_paths =
    match Fragment_queue.pop_max_allocations queue with
    | None -> hot_paths
    | Some node ->
      let hot_paths = node :: hot_paths in
      let rec remove_descendents node ~orient =
        List.iter ~f:(remove ~orient) (Data.Fragment.one_frame_extensions ~orient node)
      and remove (_, node) ~orient =
        Fragment_queue.remove queue (Data.Fragment.representative node);
        remove_descendents node ~orient
      in
      remove_descendents node ~orient:Callers;
      remove_descendents node ~orient:Callees;
      loop ~hot_paths
  in
  let hot_paths = loop ~hot_paths:[] in
  List.rev hot_paths
;;
OCaml

Innovation. Community. Security.