Source file caller_id.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
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
open! Core0
module Printexc = Stdlib.Printexc

module Mode = struct
  type t =
    | Disabled
    | Top_of_stack
    | Coverage_filtered_trace
    | Full_trace
end

(* Default caller_id mode is [Disabled]. It can be enabled by setting the environment var
   [HARDCAML_DEBUG]. If it's value is [top] then [Top_of_stack] is used - otherwise
   [Full_trace]. *)
let mode =
  let default =
    match Sys.getenv "HARDCAML_DEBUG" with
    | Some value ->
      if String.(uppercase value = "TOP") then Mode.Top_of_stack else Mode.Full_trace
    | None -> Disabled
  in
  ref default
;;

let set_mode m = mode := m

type t =
  | Top_of_stack of Call_stack.Slot.t
  | Coverage_filtered_trace of Call_stack.t
  | Full_trace of Call_stack.t
[@@deriving bin_io]

let sexp_of_t (t : t) =
  match t with
  | Top_of_stack s -> [%sexp (s : Call_stack.Slot.t)]
  | Coverage_filtered_trace s -> [%sexp (s : Call_stack.t)]
  | Full_trace s -> [%sexp (s : Call_stack.t)]
;;

let call_stack t =
  match t with
  | Top_of_stack slot -> [ slot ]
  | Coverage_filtered_trace slots -> slots
  | Full_trace slots -> slots
;;

let call_stack_opt t = Option.value_map t ~default:[] ~f:call_stack

let basic_skipped_modules =
  [ "list.ml"
  ; "list0.ml"
  ; "array.ml"
  ; "comb.ml"
  ; "interface.ml"
  ; "signal.ml"
  ; "bits.ml"
  ; "with_valid.ml"
  ; "scope.ml"
  ; "parameter.ml"
  ; "hierarchy.ml"
  ; Stdlib.__FILE__
  ]
;;

let get_skipped_modules skip =
  match skip with
  | [] -> basic_skipped_modules
  | _ -> basic_skipped_modules @ skip
;;

let get_backtrace () =
  let stack = Printexc.get_callstack 16 in
  let len = Printexc.raw_backtrace_length stack in
  stack, len
;;

let top skip =
  let skip = get_skipped_modules skip in
  let stack, len = get_backtrace () in
  let rec top pos =
    if pos = len
    then None
    else (
      let slot =
        Printexc.get_raw_backtrace_slot stack pos |> Printexc.convert_raw_backtrace_slot
      in
      match Printexc.Slot.location slot with
      | None -> None
      | Some loc ->
        if List.mem ~equal:String.equal skip loc.filename
        then top (pos + 1)
        else Some slot)
  in
  top 0 |> Option.map ~f:(fun s -> Top_of_stack (Call_stack.Slot.create s))
;;

let coverage_filtered_stack () =
  let stack, len = get_backtrace () in
  (* Exclude slots without location information *)
  let rec filtered pos =
    if pos = len
    then []
    else (
      let slot =
        Printexc.get_raw_backtrace_slot stack pos |> Printexc.convert_raw_backtrace_slot
      in
      match Printexc.Slot.location slot with
      | None -> filtered (pos + 1)
      | Some _ -> Call_stack.Slot.create slot :: filtered (pos + 1))
  in
  (* Exclude slots pertaining to the current file. *)
  let filtered =
    filtered 0
    |> List.drop_while ~f:(fun slot ->
      match slot with
      | None -> false
      | Some loc -> String.equal Stdlib.__FILE__ loc.filename)
  in
  Some (Coverage_filtered_trace filtered)
;;

let full () =
  let stack, len = get_backtrace () in
  let rec full pos =
    if pos = len
    then []
    else
      (Printexc.get_raw_backtrace_slot stack pos
       |> Printexc.convert_raw_backtrace_slot
       |> Call_stack.Slot.create)
      :: full (pos + 1)
  in
  Some (Full_trace (full 0))
;;

let get ?(skip = []) () =
  match !mode with
  | Disabled -> None
  | Top_of_stack -> top skip
  | Coverage_filtered_trace -> coverage_filtered_stack ()
  | Full_trace -> full ()
;;