Restore basic functionality to the bytecode debugger (#11065)

* debugger: the main program is now code fragment number 3 instead of 0
* debugger: update to handle stack backtrace in the presence of fibers
* Fix embedded file name (and line number) for stdlib.ml.in to get error
messages right and install it so the debugger can step through it.
* Stop cleanly if a program being debugged spawns a domain.  It is still possible to debug the program up to the point it spawns a new domain.  This is the same solution we used in #10594 for programs that create threads.
* fix the trap barrier and make it work with algebraic effects (aka fibers)
* use Caml_inline instead of inline
* debugger: use fiber id instead of address
* re-enable debugger tests
* re-enable dynlink debugging

Changes

@@ -245,6 +245,9 @@ OCaml 5.0
   documentation.
   (Jules Aguillon, review by Florian Angeletti)
 
+- #11065: Port the bytecode debugger to 5.0, adding support for effect handlers.
+  (Damien Doligez and @fabbing, review by @fabbing and Xavier Leroy)
+
 - #11079: Add the -nobanners option to dumpobj.
   (Sébastien Hinderer, review by Gabriel Scherer and Vincent Laviron)
 

debugger/.depend

@@ -474,6 +474,7 @@ program_management.cmo : \
     history.cmi \
     ../typing/envaux.cmi \
     debugger_config.cmi \
+    debugcom.cmi \
     ../driver/compmisc.cmi \
     breakpoints.cmi \
     program_management.cmi
@@ -492,6 +493,7 @@ program_management.cmx : \
     history.cmx \
     ../typing/envaux.cmx \
     debugger_config.cmx \
+    debugcom.cmx \
     ../driver/compmisc.cmx \
     breakpoints.cmx \
     program_management.cmi
@@ -642,7 +644,8 @@ trap_barrier.cmx : \
     debugcom.cmx \
     checkpoints.cmx \
     trap_barrier.cmi
-trap_barrier.cmi :
+trap_barrier.cmi : \
+    debugcom.cmi
 unix_tools.cmo : \
     ../otherlibs/unix/unix.cmi \
     ../utils/misc.cmi \

debugger/checkpoints.ml

@@ -44,7 +44,7 @@ type checkpoint = {
   mutable c_parent : checkpoint;
   mutable c_breakpoint_version : int;
   mutable c_breakpoints : (pc * int ref) list;
-  mutable c_trap_barrier : int;
+  mutable c_trap_barrier : Sp.t;
   mutable c_code_fragments : int list
   }
 
@@ -60,8 +60,8 @@ let rec root = {
   c_parent = root;
   c_breakpoint_version = 0;
   c_breakpoints = [];
-  c_trap_barrier = 0;
-  c_code_fragments = [0]
+  c_trap_barrier = Sp.null;
+  c_code_fragments = [main_frag]
   }
 
 (*** Current state ***)

debugger/checkpoints.mli

@@ -43,7 +43,7 @@ type checkpoint =
    mutable c_parent : checkpoint;
    mutable c_breakpoint_version : int;
    mutable c_breakpoints : (pc * int ref) list;
-   mutable c_trap_barrier : int;
+   mutable c_trap_barrier : Sp.t;
    mutable c_code_fragments : int list}
 
 (*** Pseudo-checkpoint `root'. ***)
@@ -57,4 +57,4 @@ val current_checkpoint : checkpoint ref
 val current_time : unit -> int64
 val current_report : unit -> report option
 val current_pc : unit -> pc option
-val current_pc_sp : unit -> (pc * int) option
+val current_pc_sp : unit -> (pc * Sp.t) option

debugger/debugcom.ml

@@ -49,6 +49,31 @@ type pc =
   { frag : int;
     pos : int; }
 
+module Sp = struct
+
+  (* Position in the debuggee's stack. *)
+  type t = {
+    block : int;
+    offset : int;
+  }
+
+  let null = { block = -1; offset = -1}
+
+  let base sp n = {sp with offset = sp.offset - n}
+
+  let compare sp1 sp2 =
+    match Stdlib.compare sp1.block sp2.block with
+    | 0 -> Stdlib.compare sp1.offset sp2.offset
+    | x -> x
+
+end
+
+(* Identifier of the code fragment for the main program.
+   Numbering starts at 1 and the runtime registers 2 fragments before
+   the main program: one for uncaught exceptions and one for callbacks.
+*)
+let main_frag = 3
+
 let set_event {frag; pos} =
   output_char !conn.io_out 'e';
   output_binary_int !conn.io_out frag;
@@ -79,7 +104,7 @@ type execution_summary =
 type report = {
   rep_type : execution_summary;
   rep_event_count : int64;
-  rep_stack_pointer : int;
+  rep_stack_pointer : Sp.t;
   rep_program_pointer : pc
 }
 
@@ -112,12 +137,13 @@ let do_go_smallint n =
          |  c  -> Misc.fatal_error (Printf.sprintf "Debugcom.do_go %c" c)
        in
        let event_counter = input_binary_int !conn.io_in in
-       let stack_pos = input_binary_int !conn.io_in in
+       let block = input_binary_int !conn.io_in in
+       let offset = input_binary_int !conn.io_in in
        let frag = input_binary_int !conn.io_in in
        let pos = input_binary_int !conn.io_in in
        { rep_type = summary;
          rep_event_count = Int64.of_int event_counter;
-         rep_stack_pointer = stack_pos;
+         rep_stack_pointer = Sp.{block; offset};
          rep_program_pointer = {frag; pos} })
 
 let rec do_go n =
@@ -166,10 +192,11 @@ let wait_child chan =
 let initial_frame () =
   output_char !conn.io_out '0';
   flush !conn.io_out;
-  let stack_pos = input_binary_int !conn.io_in in
+  let block = input_binary_int !conn.io_in in
+  let offset = input_binary_int !conn.io_in in
   let frag = input_binary_int !conn.io_in in
   let pos = input_binary_int !conn.io_in in
-  (stack_pos, {frag; pos})
+  (Sp.{block; offset}, {frag; pos})
 
 let set_initial_frame () =
   ignore(initial_frame ())
@@ -182,35 +209,43 @@ let up_frame stacksize =
   output_char !conn.io_out 'U';
   output_binary_int !conn.io_out stacksize;
   flush !conn.io_out;
-  let stack_pos = input_binary_int !conn.io_in in
+  let block = input_binary_int !conn.io_in in
+  let offset = input_binary_int !conn.io_in in
   let frag, pos =
-    if stack_pos = -1
-    then 0, 0
-    else let frag = input_binary_int !conn.io_in in
-         let pos = input_binary_int !conn.io_in in
-         frag, pos
+    if block = -1 then
+    begin
+      assert (offset = -1);
+      0, 0
+    end else begin
+      let frag = input_binary_int !conn.io_in in
+      let pos = input_binary_int !conn.io_in in
+      frag, pos
+    end
   in
-  (stack_pos, { frag; pos })
+  (Sp.{block; offset}, { frag; pos })
 
 (* Get and set the current frame position *)
 
 let get_frame () =
   output_char !conn.io_out 'f';
   flush !conn.io_out;
-  let stack_pos = input_binary_int !conn.io_in in
+  let block = input_binary_int !conn.io_in in
+  let offset = input_binary_int !conn.io_in in
   let frag = input_binary_int !conn.io_in in
   let pos = input_binary_int !conn.io_in in
-  (stack_pos, {frag; pos})
+  (Sp.{block; offset}, {frag; pos})
 
 let set_frame stack_pos =
   output_char !conn.io_out 'S';
-  output_binary_int !conn.io_out stack_pos
+  output_binary_int !conn.io_out stack_pos.Sp.block;
+  output_binary_int !conn.io_out stack_pos.Sp.offset
 
 (* Set the trap barrier to given stack position. *)
 
 let set_trap_barrier pos =
   output_char !conn.io_out 'b';
-  output_binary_int !conn.io_out pos
+  output_binary_int !conn.io_out pos.Sp.block;
+  output_binary_int !conn.io_out pos.Sp.offset
 
 (* Handling of remote values *)
 

debugger/debugcom.mli

@@ -16,10 +16,19 @@
 
 (* Low-level communication with the debuggee *)
 
+module Sp : sig
+  type t
+  val null : t
+  val base : t -> int -> t
+  val compare : t -> t -> int
+end
+
 type pc =
   { frag : int;
     pos : int; }
 
+val main_frag : int
+
 type execution_summary =
     Event
   | Breakpoint
@@ -33,7 +42,7 @@ type execution_summary =
 type report =
   { rep_type : execution_summary;
     rep_event_count : int64;
-    rep_stack_pointer : int;
+    rep_stack_pointer : Sp.t;
     rep_program_pointer : pc }
 
 type checkpoint_report =
@@ -70,23 +79,25 @@ val wait_child : Primitives.io_channel -> unit
 
 (* Move to initial frame (that of current function). *)
 (* Return stack position and current pc *)
-val initial_frame : unit -> int * pc
+val initial_frame : unit -> Sp.t * pc
 val set_initial_frame : unit -> unit
 
 (* Get the current frame position *)
 (* Return stack position and current pc *)
-val get_frame : unit -> int * pc
+val get_frame : unit -> Sp.t * pc
 
 (* Set the current frame *)
-val set_frame : int -> unit
+val set_frame : Sp.t -> unit
 
 (* Move up one frame *)
 (* Return stack position and current pc.
-   If there's no frame above, return (-1, 0). *)
-val up_frame : int -> int * pc
+   If there's no frame above, return (null_sp, _).
+   The argument is the size of the current frame.
+ *)
+val up_frame : int -> Sp.t * pc
 
 (* Set the trap barrier to given stack position. *)
-val set_trap_barrier : int -> unit
+val set_trap_barrier : Sp.t -> unit
 
 (* Set whether the debugger follow the child or the parent process on fork *)
 val fork_mode : follow_fork_mode ref

debugger/debugger_parser.mly

@@ -237,7 +237,8 @@ expression_list_eol :
 
 break_argument_eol :
     end_of_line                                 { BA_none }
-  | integer_eol                                 { BA_pc {frag = 0; pos = $1} }
+  | integer_eol                                 { BA_pc {frag = main_frag;
+                                                         pos = $1} }
   | INTEGER COLON integer_eol                   { BA_pc {frag = to_int $1;
                                                          pos = $3} }
   | expression end_of_line                      { BA_function $1 }

debugger/frames.ml

@@ -53,7 +53,7 @@ let selected_event_is_before () =
 let rec move_up frame_count event =
   if frame_count <= 0 then event else begin
     let (sp, pc) = up_frame event.ev_ev.ev_stacksize in
-    if sp < 0 then raise Not_found;
+    if sp = Sp.null then raise Not_found;
     move_up (frame_count - 1) (any_event_at_pc pc)
   end
 
@@ -113,7 +113,7 @@ let do_backtrace action =
       begin try
         while action (Some !event) do
           let (sp, pc) = up_frame !event.ev_ev.ev_stacksize in
-          if sp < 0 then raise Exit;
+          if sp = Sp.null then raise Exit;
           event := any_event_at_pc pc
         done
       with Exit -> ()

debugger/program_management.ml

@@ -127,7 +127,7 @@ let initialize_loading () =
     raise Toplevel;
   end;
   Symbols.clear_symbols ();
-  Symbols.read_symbols 0 !program_name;
+  Symbols.read_symbols Debugcom.main_frag !program_name;
   let dirs = Load_path.get_paths () @ !Symbols.program_source_dirs in
   Load_path.init ~auto_include:Compmisc.auto_include dirs;
   Envaux.reset_cache ();
@@ -136,7 +136,7 @@ let initialize_loading () =
   open_connection !socket_name
     (function () ->
       go_to _0;
-      Symbols.set_all_events 0;
+      Symbols.set_all_events Debugcom.main_frag;
       exit_main_loop ())
 
 (* Ensure the program is already loaded. *)

debugger/time_travel.ml

@@ -380,8 +380,8 @@ let new_checkpoint pid fd =
      c_parent = root;
      c_breakpoint_version = 0;
      c_breakpoints = [];
-     c_trap_barrier = 0;
-     c_code_fragments = [0]}
+     c_trap_barrier = Sp.null;
+     c_code_fragments = [main_frag]}
   in
     insert_checkpoint new_checkpoint
 
@@ -555,7 +555,7 @@ let finish () =
   | Some {ev_ev={ev_stacksize}} ->
       set_initial_frame();
       let (frame, pc) = up_frame ev_stacksize in
-      if frame < 0 then begin
+      if frame = Sp.null then begin
         prerr_endline "`finish' not meaningful in outermost frame.";
         raise Toplevel
       end;
@@ -598,8 +598,9 @@ let next_1 () =
         | Some {ev_ev={ev_stacksize=ev_stacksize2}} ->
             let (frame2, _pc2) = initial_frame() in
             (* Call `finish' if we've entered a function. *)
-            if frame1 >= 0 && frame2 >= 0 &&
-               frame2 - ev_stacksize2 > frame1 - ev_stacksize1
+            if frame1 <> Sp.null && frame2 <> Sp.null &&
+               Sp.(compare (base frame2 ev_stacksize2)
+                     (base frame1 ev_stacksize1)) > 0
             then finish()
       end
 
@@ -622,7 +623,7 @@ let start () =
   | Some {ev_ev={ev_stacksize}} ->
       let (frame, _) = initial_frame() in
       let (frame', pc) = up_frame ev_stacksize in
-      if frame' < 0 then begin
+      if frame' = Sp.null then begin
         prerr_endline "`start not meaningful in outermost frame.";
         raise Toplevel
       end;
@@ -644,7 +645,7 @@ let start () =
             step _minus1;
             (not !interrupted)
               &&
-            (frame' - nargs > frame - ev_stacksize)
+            Sp.(compare (base frame' nargs) (base frame ev_stacksize)) > 0
         | _ ->
             false
       do
@@ -666,8 +667,9 @@ let previous_1 () =
         | Some {ev_ev={ev_stacksize=ev_stacksize2}} ->
             let (frame2, _pc2) = initial_frame() in
             (* Call `start' if we've entered a function. *)
-            if frame1 >= 0 && frame2 >= 0 &&
-               frame2 - ev_stacksize2 > frame1 - ev_stacksize1
+            if frame1 <> Sp.null && frame2 <> Sp.null &&
+              Sp.(compare (base frame2 ev_stacksize2)
+                    (base frame1 ev_stacksize1)) > 0
             then start()
       end
 

debugger/trap_barrier.ml

@@ -19,13 +19,13 @@
 open Debugcom
 open Checkpoints
 
-let current_trap_barrier = ref 0
+let current_trap_barrier = ref Sp.null
 
 let install_trap_barrier pos =
   current_trap_barrier := pos
 
 let remove_trap_barrier () =
-  current_trap_barrier := 0
+  current_trap_barrier := Sp.null
 
 (* Ensure the trap barrier state is up to date in current checkpoint. *)
 let update_trap_barrier () =

debugger/trap_barrier.mli

@@ -16,7 +16,7 @@
 
 (************************* Trap barrier ********************************)
 
-val install_trap_barrier : int -> unit
+val install_trap_barrier : Debugcom.Sp.t -> unit
 
 val remove_trap_barrier : unit -> unit
 
@@ -25,4 +25,4 @@ val update_trap_barrier : unit -> unit
 
 (* Execute `funct' with a trap barrier. *)
 (* --- Used by `finish'. *)
-val exec_with_trap_barrier : int -> (unit -> unit) -> unit
+val exec_with_trap_barrier : Debugcom.Sp.t -> (unit -> unit) -> unit