Source file debuggers.ml

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