Fix for PR2755 (ocamltest fail-if-test-does-nothing) (ocaml-flambda#3340

)

* Fix for PR2755, ocamltest

* test

* Restrict DLS_thread_safety to runtime5

ocamltest/main.ml

@@ -107,12 +107,14 @@ let join_summaries sa sb =
   | No_failure, (No_failure | All_skipped)
   | All_skipped, No_failure -> No_failure
 
-let rec run_test_tree log common_prefix behavior env summ ast =
+let rec run_test_tree log common_prefix behavior env summ ast
+      ~must_do_something =
   match ast with
   | Ast (Environment_statement s :: stmts, subs) ->
     begin match interpret_environment_statement env s with
     | env ->
       run_test_tree log common_prefix behavior env summ (Ast (stmts, subs))
+        ~must_do_something
     | exception e ->
       let line = s.loc.Location.loc_start.Lexing.pos_lnum in
       Printf.printf "%s line %d %!" common_prefix line;
@@ -133,27 +135,49 @@ let rec run_test_tree log common_prefix behavior env summ ast =
     in
     if not skip_all then
       Printf.printf "%s %s (%s) %!" common_prefix locstr name.node;
+    let test = lookup_test name in
+    let must_do_something =
+      must_do_something && not (Tests.does_something test)
+    in
     let (msg, children_behavior, newenv, result) =
       match behavior with
       | Skip_all -> ("", Skip_all, env, Result.skip)
       | Run ->
         begin try
           let testenv = List.fold_left apply_modifiers env mods in
-          let test = lookup_test name in
           let (result, newenv) = Tests.run log testenv test in
           let msg = Result.string_of_result result in
           let sub_behavior = if Result.is_pass result then Run else Skip_all in
           (msg, sub_behavior, newenv, result)
-        with e -> (report_error name.loc e, Skip_all, env, Result.fail)
+        with e ->
+          (report_error name.loc e, Skip_all, env, Result.fail)
         end
     in
     if not skip_all then Printf.printf "%s\n%!" msg;
     let newsumm = join_result summ result in
     let newast = Ast (stmts, subs) in
     run_test_tree log common_prefix children_behavior newenv newsumm newast
+      ~must_do_something
+  | Ast ([], []) ->
+    if not must_do_something then summ
+    else (
+      match summ with
+      | No_failure ->
+        Printf.printf "%s: does the test tree do something? => failed\n%!"
+          common_prefix;
+        Some_failure
+      | All_skipped | Some_failure -> summ
+    )
   | Ast ([], subs) ->
+    (* CR mshinwell/xclerc: maybe sequences of actions that "do something" and
+       then have further actions that do not "do something" should be
+       flagged *)
     List.fold_left join_summaries summ
-      (List.map (run_test_tree log common_prefix behavior env All_skipped) subs)
+      (List.map (run_test_tree log common_prefix behavior env All_skipped
+        ~must_do_something) subs)
+
+let run_test_tree log common_prefix behavior env summ ast =
+  run_test_tree log common_prefix behavior env summ ast ~must_do_something:true
 
 let get_test_source_directory test_dirname =
   if (Filename.is_relative test_dirname) then

ocamltest/tests.ml

@@ -29,13 +29,6 @@ let null = {
   test_description = "dummy test inserted by parser; always pass"
 }
 
-let does_nothing = {
-  test_name = "test does nothing";
-  test_run_by_default = false;
-  test_actions = [Actions_helpers.fail_with_reason "test does nothing"];
-  test_description = "inserted when a test does not do any substantive action"
-}
-
 let compare t1 t2 = String.compare t1.test_name t2.test_name
 
 let (tests: (string, t) Hashtbl.t) = Hashtbl.create 20
@@ -98,3 +91,6 @@ module TestSet = Set.Make
   type nonrec t = t
   let compare = compare
 end)
+
+let does_something t =
+  List.exists Actions.does_something t.test_actions

ocamltest/tests.mli

@@ -24,8 +24,6 @@ type t = {
 
 val null : t
 
-val does_nothing : t
-
 val compare : t -> t -> int
 
 val register : t -> unit
@@ -41,3 +39,5 @@ val run : out_channel -> Environments.t -> t -> Result.t * Environments.t
 val test_of_action : Actions.t -> t
 
 module TestSet : Set.S with type elt = t
+
+val does_something : t -> bool

ocamltest/tsl_semantics.ml

@@ -74,19 +74,6 @@ type test_tree =
     string located list *
     (test_tree list)
 
-let tests_do_something (tests : Tests.t) =
-  List.exists Actions.does_something tests.test_actions
-
-(* CR mshinwell/xclerc: maybe sequences of actions that "do something" and
-   then have further actions that do not "do something" should be
-   flagged *)
-let rec test_tree_does_something_on_all_branches tree =
-  match tree with
-  | Node (_, tests, _, []) -> tests_do_something tests
-  | Node (_, tests, _, children) ->
-    tests_do_something tests
-    || List.for_all test_tree_does_something_on_all_branches children
-
 let too_deep testname max_level real_level =
   Printf.eprintf "Test %s should have depth atmost %d but has depth %d\n%!"
     testname max_level real_level;
@@ -153,21 +140,6 @@ let test_trees_of_tsl_block tsl_block =
     | (Environment_statement s)::_ -> unexpected_environment_statement s
     | _ -> assert false
 
-let test_trees_of_tsl_block tsl_block =
-  let (env, trees) = test_trees_of_tsl_block tsl_block in
-  let does_something =
-    List.for_all test_tree_does_something_on_all_branches trees
-  in
-  if does_something then env, trees
-  else
-    let tree =
-      match trees with
-      | [] -> []
-      | Node (_, _, name, _) :: _ ->
-        [Node ([], Tests.does_nothing, name, [])]
-    in
-    env, tree
-
 let tests_in_stmt set stmt =
   match stmt with
   | Environment_statement _ -> set

testsuite/tests/lib-domain/DLS_thread_safety.ml

@@ -1,6 +1,9 @@
 (* TEST
    include systhreads;
    hassysthreads;
+   runtime5;
+   { bytecode; }
+   { native; }
 *)
 
 (* This test creates [nb_keys] DLS keys, each storing an atomic integer.

testsuite/tests/lib-unix/common/bigarrays.ml

@@ -1,6 +1,8 @@
 (* TEST
 include unix;
 hasunix;
+{ bytecode; }
+{ native; }
 *)
 
 let filename = "test.out"