package shexp

  1. Overview
  2. Docs

Source file debuggers.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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
open Import

module type S = Debugger_intf.S

module Counter = struct
  type t =
    { mutable value : int
    ; mutex         : Mutex.t
    }

  let create initial =
    { value = initial
    ; mutex = Mutex.create ()
    }

  let get_and_add t x =
    Mutex.lock t.mutex;
    let n = t.value in
    t.value <- n + x;
    Mutex.unlock t.mutex;
    n

  let next t = get_and_add t 1
end

let lines_of_raw_backtrace t =
  let rec loop i acc =
    if i < 0 then
      acc
    else
      let slot =
        Printexc.get_raw_backtrace_slot t i
        |> Printexc.convert_raw_backtrace_slot
      in
      let acc =
        match Printexc.Slot.format i slot with
        | None -> acc
        | Some s -> s :: acc
      in
      loop (i - 1) acc
  in
  let len = Printexc.raw_backtrace_length t in
  loop (len - 1) []


let exn_with_backtrace e bt =
  Sexp.(exn e :: List.map (lines_of_raw_backtrace bt) ~f:string)

module Logger = struct
  type t =
    { out            : Sexp.t -> unit
    ; next_thread_id : Counter.t
    ; thread_id      : int
    ; next_prim_id   : Counter.t
    }

  type (_, _) prim_token = int

  let create out =
    { out
    ; next_thread_id = Counter.create 1
    ; thread_id      = 0
    ; next_prim_id   = Counter.create 0
    }

  let before_prim t prim args =
    let id = Counter.next t.next_prim_id in
    t.out Sexp.(
      List [ List [ Atom "thread" ; int t.thread_id ]
           ; List [ Atom "id"     ; int id          ]
           ; Prim.sexp_of_call prim args
           ]
    );
    id

  let after_prim t prim res id =
    let res : Sexp.t list =
      match res with
      | Ok x ->
        [ Atom "->"
        ; match Prim.sexp_of_result prim x with
        | None -> List []
        | Some s -> s
        ]
      | Error (e, bt) ->
        [ Atom "raised"
        ; List (exn_with_backtrace e bt)
        ]
    in
    t.out Sexp.(
      List (List [ Atom "thread" ; int t.thread_id ] ::
            List [ Atom "id"     ; int id          ] ::
            res)
    )

  let user_exn t e bt =
    t.out Sexp.(
      record [ "thread"   , int t.thread_id
             ; "user-exn" , List (exn_with_backtrace e bt)
             ]
    )

  let fork t =
    let id = Counter.get_and_add t.next_thread_id 2 in
    let t1 = { t with thread_id = id     } in
    let t2 = { t with thread_id = id + 1 } in
    t.out Sexp.(
      cstr_record "fork"
        [ "thread1", int t1.thread_id
        ; "thread2", int t2.thread_id
        ]
    );
    (t1, t2)

  let end_fork t t1 t2 =
    t.out Sexp.(
      cstr_record "end-fork"
        [ "thread1", int t1.thread_id
        ; "thread2", int t2.thread_id
        ]
    )

  let output t s =
    t.out (Atom s)

  let enter_sub _ = ()
  let leave_sub _ = ()
  let force_threads = false
end

module Tracer = struct
  type t =
    { mutable stack       : Sexp.t list
    ; mutable length      : int
    ; mutable checkpoints : int list
    }

  type (_, _) prim_token = unit

  let create () =
    { stack       = []
    ; length      = 0
    ; checkpoints = []
    }

  let result t = Sexp.List (List.rev t.stack)

  let add t sexp =
    t.length <- t.length + 1;
    t.stack <- sexp :: t.stack

  let before_prim t prim args = add t (Prim.sexp_of_call prim args)

  let after_prim t prim res () =
    match res with
    | Ok x ->
      (match Prim.sexp_of_result prim x with
       | None -> ()
       | Some sexp -> add t (List [Atom "->"; sexp]))
    | Error (e, bt) ->
      add t Sexp.(cstr "raised" (exn_with_backtrace e bt))

  let user_exn t e bt =
    add t Sexp.(cstr "user-exn" (exn_with_backtrace e bt))

  let output t s =
    add t (Atom s)

  let fork _ = (create (), create ())

  let end_fork t t1 t2 =
    add t (Sexp.cstr "fork" [result t1; result t2])

  let enter_sub t =
    t.checkpoints <- t.length :: t.checkpoints

  let pop_checkpoint t =
    match t.checkpoints with
    | [] -> assert false
    | x :: l -> t.checkpoints <- l; x

  let leave_sub t =
    let rec split stack acc n =
      if n = 0 then
        (acc, stack)
      else
        match stack with
        | [] -> assert false
        | x :: stack -> split stack (x :: acc) (n - 1)
    in
    let checkpoint = pop_checkpoint t in
    let items, stack = split t.stack [] (t.length - checkpoint) in
    t.stack  <- stack;
    t.length <- checkpoint;
    add t (Sexp.cstr "do" items)

  let force_threads = false
end
OCaml

Innovation. Community. Security.