CP-49134: tracing: do not destroy stacktrace (#6117)

Reraise with the original stacktrace, this requires using the raw
backtrace instead of the string one.

I had this change sitting in a branch since around Apr 25 2024, although
the branch itself might need more testing, this is a simple fix that we
should probably get in sooner.

ocaml/libs/tracing/tracing.ml

@@ -331,6 +331,7 @@ module Span = struct
     | exn, stacktrace -> (
         let msg = Printexc.to_string exn in
         let exn_type = Printexc.exn_slot_name exn in
+        let stacktrace = Printexc.raw_backtrace_to_string stacktrace in
         let _description =
           Some
             (Printf.sprintf "Error: %s Type: %s Backtrace: %s" msg exn_type
@@ -720,10 +721,10 @@ let with_tracing ?(attributes = []) ?(parent = None) ~name f =
         ignore @@ Tracer.finish span ;
         result
       with exn ->
-        let backtrace = Printexc.get_backtrace () in
+        let backtrace = Printexc.get_raw_backtrace () in
         let error = (exn, backtrace) in
         ignore @@ Tracer.finish span ~error ;
-        raise exn
+        Printexc.raise_with_backtrace exn backtrace
     )
     | Error e ->
         warn "Failed to start tracing: %s" (Printexc.to_string e) ;

ocaml/libs/tracing/tracing.mli

@@ -163,7 +163,9 @@ module Tracer : sig
   *)
 
   val finish :
-    ?error:exn * string -> Span.t option -> (Span.t option, exn) result
+       ?error:exn * Printexc.raw_backtrace
+    -> Span.t option
+    -> (Span.t option, exn) result
 
   val span_hashtbl_is_empty : unit -> bool
 

ocaml/tests/test_observer.ml

@@ -466,7 +466,7 @@ let test_tracing_exn_backtraces () =
       let (_ : int) = test_a () in
       ()
     with e -> (
-      let stacktrace = Printexc.get_backtrace () in
+      let stacktrace = Printexc.get_raw_backtrace () in
       let x = Tracer.finish ~error:(e, stacktrace) x in
       match x with
       | Ok (Some span) ->

ocaml/xapi/context.ml

@@ -517,7 +517,7 @@ let with_tracing ?originator ~__context name f =
       result
     with exn ->
       let backtrace = Printexc.get_raw_backtrace () in
-      let error = (exn, Printexc.raw_backtrace_to_string backtrace) in
+      let error = (exn, backtrace) in
       ignore @@ Tracer.finish span ~error ;
       Printexc.raise_with_backtrace exn backtrace
   )

ocaml/xapi/context.mli

@@ -142,7 +142,7 @@ val get_client_ip : t -> string option
 
 val get_user_agent : t -> string option
 
-val complete_tracing : ?error:exn * string -> t -> unit
+val complete_tracing : ?error:exn * Printexc.raw_backtrace -> t -> unit
 
 val tracing_of : t -> Tracing.Span.t option
 

ocaml/xapi/taskHelper.ml

@@ -265,7 +265,7 @@ let cancel ~__context =
   cancel_this ~__context ~self
 
 let failed ~__context exn =
-  let backtrace = Printexc.get_backtrace () in
+  let backtrace = Printexc.get_raw_backtrace () in
   let@ () = finally_complete_tracing ~error:(exn, backtrace) __context in
   let code, params = ExnHelper.error_of_exn exn in
   let@ self = operate_on_db_task ~__context in

ocaml/xenopsd/lib/xenops_server.ml

@@ -1840,7 +1840,7 @@ let with_tracing ~name ~task f =
         Xenops_task.set_tracing task parent ;
         result
       with exn ->
-        let backtrace = Printexc.get_backtrace () in
+        let backtrace = Printexc.get_raw_backtrace () in
         let error = (exn, backtrace) in
         ignore @@ Tracer.finish span ~error ;
         raise exn