flambda-backend: Fix backtrace_dynlink

Author: mshinwell

testsuite/tests/backtrace/backtrace_dynlink.flambda.reference

@@ -1,16 +1,16 @@
-Raised by primitive operation at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 6, characters 13-38
+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 Dynlink_internal_native.Native.run.(fun) in file "otherlibs/dynlink/dynlink.ml" (inlined), line 132, characters 25-58
 Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15
 Called from Dynlink_internal_native.Native.run in file "otherlibs/dynlink/dynlink.ml", line 132, characters 4-107
 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" (inlined), 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 39, characters 4-71
+Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 76, characters 4-71
 execution of module initializers in the shared library failed: Failure("SUCCESS")
 Raised at Stdlib.failwith in file "stdlib.ml" (inlined), line 34, characters 17-33
-Called from Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 3, characters 4-22
-Re-raised at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 8, characters 5-12
+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
@@ -21,4 +21,4 @@ Called from Dynlink_common.Make.load.(fun) in file "otherlibs/dynlink/dynlink_co
 Called from Stdlib__List.iter in file "list.ml" (inlined), 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 39, characters 4-71
+Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 76, characters 4-71

testsuite/tests/backtrace/backtrace_dynlink.ml

@@ -33,14 +33,51 @@ reference = "${test_source_directory}/backtrace_dynlink.flambda.reference"
 (* 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
+
 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;
-     Printexc.print_backtrace stdout;
+     print_string (process_backtrace (Printexc.get_backtrace ()))
   | exn ->
      Printexc.to_string exn |> print_endline;
      print_endline "ERROR"

testsuite/tests/backtrace/backtrace_dynlink.reference

@@ -1,14 +1,14 @@
-Raised by primitive operation at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 6, characters 13-38
+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 39, characters 4-71
+Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 76, characters 4-71
 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 3, characters 4-22
-Re-raised at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 8, characters 5-12
+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
@@ -17,4 +17,4 @@ Called from Dynlink_common.Make.load.(fun) in file "otherlibs/dynlink/dynlink_co
 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 39, characters 4-71
+Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 76, characters 4-71

testsuite/tests/backtrace/backtrace_dynlink_plugin.ml

@@ -1,8 +1,49 @@
+(* 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
-     Printexc.print_raw_backtrace stdout c;
+     process_backtrace (Printexc.raw_backtrace_to_string c)
+     |> print_string;
      raise e