flambda-backend: Rework backtrace_dynlink

ocaml-flambda · Nov 3, 2023 · 046d5f1 · 046d5f1
1 parent 19977f4
commit 046d5f1
Show file tree

Hide file tree

Showing 4 changed files with 29 additions and 138 deletions.
diff --git a/testsuite/tests/backtrace/backtrace_dynlink.flambda.reference b/testsuite/tests/backtrace/backtrace_dynlink.flambda.reference
diff --git a/testsuite/tests/backtrace/backtrace_dynlink.ml b/testsuite/tests/backtrace/backtrace_dynlink.ml
@@ -22,62 +22,31 @@ libraries = "dynlink"
 all_modules = "backtrace_dynlink.cmx"
 ***** run
 ocamlrunparam += ",b=1"
-****** no-flambda
-******* check-program-output
-****** flambda
-reference = "${test_source_directory}/backtrace_dynlink.flambda.reference"
-******* check-program-output
+****** check-program-output
 *)
 
 (* test for backtrace and stack unwinding with dynlink. *)
 (* https://github.com/ocaml-multicore/ocaml-multicore/issues/440 *)
 (* https://github.com/ocaml-multicore/ocaml-multicore/pull/499 *)
 
-(* Postprocess backtrace to ignore differences between dune and make
-   builds (in the former, Dynlink.Native is Dynlink_internal_native.Native) *)
-let begins_with ?(from = 0) str ~prefix =
-  (* From utils/misc.ml *)
-  let rec helper idx =
-    if idx < 0 then true
-    else
-      String.get str (from + idx) = String.get prefix idx && helper (idx-1)
-  in
-  let n = String.length str in
-  let m = String.length prefix in
-  if n >= from + m then helper (m-1) else false
 
-let process_backtrace bt =
-  let bt = String.split_on_char '\n' bt in
-  let bt =
-    List.map (fun line ->
-        let prefix = "Called from Dynlink.Native" in
-        if begins_with line ~prefix
-        then
-          "Called from Dynlink_internal_native.Native" ^
-            (String.sub line (String.length prefix)
-              (String.length line - String.length prefix))
-        else
-          let prefix = "Re-raised at Dynlink.Native" in
-          if begins_with line ~prefix
-          then
-            "Re-raised at Dynlink_internal_native.Native" ^
-              (String.sub line (String.length prefix)
-                (String.length line - String.length prefix))
-          else
-            line
-      )
-      bt
-  in
-  String.concat "\n" bt
+[@@@ocaml.warning "-52"]
 
-let ()  =
+let () =
   Dynlink.allow_unsafe_modules true;
   try
     (Dynlink.loadfile [@inlined never]) "backtrace_dynlink_plugin.cmxs"
   with
-  | Dynlink.Error err ->
-     print_endline @@ Dynlink.error_message err;
-     print_string (process_backtrace (Printexc.get_backtrace ()))
+  | Dynlink.Error ((Library's_module_initializers_failed (
+      Failure "SUCCESS")) as err) ->
+    print_endline (Dynlink.error_message err);
+    let bt = Printexc.get_backtrace () in
+    let bt_list = String.split_on_char '\n' bt in
+    if List.length bt_list > 5 then print_endline "Backtrace sufficiently long"
+    else (
+      print_endline "Failure: Backtrace too short:";
+      print_string bt
+    )
   | exn ->
-     Printexc.to_string exn |> print_endline;
-     print_endline "ERROR"
+    Printexc.to_string exn |> print_endline;
+    print_endline "ERROR"
diff --git a/testsuite/tests/backtrace/backtrace_dynlink.reference b/testsuite/tests/backtrace/backtrace_dynlink.reference
@@ -1,20 +1,3 @@
-Raised by primitive operation at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 46, characters 13-38
-Called from Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 112, characters 8-25
-Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15
-Called from Dynlink_common.Make.load.(fun) in file "otherlibs/dynlink/dynlink_common.ml", line 367, characters 13-72
-Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15
-Called from Dynlink_common.Make.load in file "otherlibs/dynlink/dynlink_common.ml", line 363, characters 8-408
-Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 76, characters 4-71
+Backtrace sufficiently long (in plugin)
 execution of module initializers in the shared library failed: Failure("SUCCESS")
-Raised at Stdlib.failwith in file "stdlib.ml", line 34, characters 17-33
-Called from Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 43, characters 4-22
-Re-raised at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 49, characters 5-12
-Called from Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 112, characters 8-25
-Called from Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 112, characters 8-25
-Re-raised at Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 124, characters 6-137
-Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15
-Called from Dynlink_common.Make.load.(fun) in file "otherlibs/dynlink/dynlink_common.ml", line 367, characters 13-72
-Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15
-Called from Dynlink_common.Make.load in file "otherlibs/dynlink/dynlink_common.ml", line 363, characters 8-408
-Re-raised at Dynlink_common.Make.load in file "otherlibs/dynlink/dynlink_common.ml", line 376, characters 8-17
-Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 76, characters 4-71
+Backtrace sufficiently long
diff --git a/testsuite/tests/backtrace/backtrace_dynlink_plugin.ml b/testsuite/tests/backtrace/backtrace_dynlink_plugin.ml
@@ -1,49 +1,17 @@
-(* CR mshinwell: Find a way of doing this postprocessing properly and
-   removing the duplication with backtrace_dynlink.ml *)
-
-(* Postprocess backtrace to ignore differences between dune and make
-   builds (in the former, Dynlink.Native is Dynlink_internal_native.Native) *)
-let begins_with ?(from = 0) str ~prefix =
-  (* From utils/misc.ml *)
-  let rec helper idx =
-    if idx < 0 then true
-    else
-      String.get str (from + idx) = String.get prefix idx && helper (idx-1)
-  in
-  let n = String.length str in
-  let m = String.length prefix in
-  if n >= from + m then helper (m-1) else false
-
-let process_backtrace bt =
-  let bt = String.split_on_char '\n' bt in
-  let bt =
-    List.map (fun line ->
-        let prefix = "Called from Dynlink.Native" in
-        if begins_with line ~prefix
-        then
-          "Called from Dynlink_internal_native.Native" ^
-            (String.sub line (String.length prefix)
-              (String.length line - String.length prefix))
-        else
-          let prefix = "Re-raised at Dynlink.Native" in
-          if begins_with line ~prefix
-          then
-            "Re-raised at Dynlink_internal_native.Native" ^
-              (String.sub line (String.length prefix)
-                (String.length line - String.length prefix))
-          else
-            line
-      )
-      bt
-  in
-  String.concat "\n" bt
-
 let () =
   try
     failwith "SUCCESS"
   with
   | e ->
-     let c = Printexc.get_callstack 10 in
-     process_backtrace (Printexc.raw_backtrace_to_string c)
-     |> print_string;
-     raise e
+    let c = Printexc.get_callstack 10 in
+    let bt = Printexc.raw_backtrace_to_string c in
+    let bt_list = String.split_on_char '\n' bt in
+    if List.length bt_list > 5 then (
+      print_endline "Backtrace sufficiently long (in plugin)";
+      raise e
+    )
+    else (
+      print_endline "Failure: Backtrace too short (in plugin):";
+      print_string bt;
+      raise e
+    )