Fix regression when compiling with unique fibers enabled. Extend CI w…

…orkflow with unique fibers tests.

.github/workflows/default.yml

@@ -45,3 +45,14 @@ jobs:
       - name: Run tests
         run: opam exec -- dune build @runtest
         shell: bash
+
+      - name: Rebuild library with UNIQUE_FIBERS
+        run: |
+          opam exec -- dune build
+          opam exec -- dune install
+        env: UNIQUE_FIBERS=1
+        shell: bash
+
+      - name: Rerun tests
+        run: opam exec -- dune build @runtest
+        shell: bash

Makefile

@@ -30,3 +30,4 @@ test:
 .PHONY: clean
 clean:
 	dune clean --build-dir=$(BUILD_DIR)
+	echo -n "; intentionally left empty" > test/tests.inc

lib/fiber_primitives.h

@@ -10,7 +10,7 @@
 // uses the non-negative range of `int64_t`, therefore to ensure
 // uniqueness amongst all fibers, we can use the negative range of
 // `int64_t` to assign identifiers to cloned fibers.
-extern _Atomic int64_t multicont_fiber_id;
+static _Atomic int64_t multicont_fiber_id;
 #define MULTICONT_NEXT_FIBER_ID atomic_fetch_sub(&multicont_fiber_id, 1)
 #endif
 

test/gen/testrules.ml

@@ -17,14 +17,14 @@ let detect_native_compiler ocamlc =
     List.exists (fun s -> String.equal s "native_compiler: true") lines
   with _ -> false
 
-let make_stanzas native testname =
+let make_diff_stanzas native testname =
   let stanzas exe_prefix =
     let output =
       Printf.sprintf
         "(rule\n\
          \ (with-stdout-to %s.output\n\
          \ (setenv \"LD_LIBRARY_PATH\" \".\"\n\
-         \ (run %s/examples/%s.exe))))"
+         \   (run %s/examples/%s.exe))))"
         exe_prefix "%{workspace_root}" exe_prefix
     in
     let runtest =
@@ -46,10 +46,31 @@ let write_content filename stanzas =
   in
   C.Flags.write_lines filename stanzas
 
+(* Currently only for the test/lib/unique_fibers.ml test *)
+let make_nondiff_stanzas native testname : string list =
+  let stanza exe_prefix =
+    Printf.sprintf
+      "(rule\n\
+       \ (alias runtest)\n\
+       \ (action\n\
+       \   (setenv \"TEST_UNIQUE_FIBERS\" \"%s\"\n\
+       \     (setenv \"LD_LIBRARY_PATH\" \".\"\n\
+       \       (run %s/test/lib/%s.exe)))))"
+      (match Sys.getenv_opt "UNIQUE_FIBERS" with
+       | Some "1" -> "true" | _ -> "false")
+      "%{workspace_root}" exe_prefix
+  in
+  let bc = stanza (Printf.sprintf "%s.bc" testname) in
+  let nc = if native then [stanza testname] else [] in
+  (Printf.sprintf "; %s tests" testname) :: bc :: "" :: nc
+
 let _ =
-  let testnames =
+  let diff_testnames =
     ["async"; "choice"; "generic_count"; "nqueens"; "supervised"]
   in
+  let nondiff_testnames =
+    ["unique_fibers"]
+  in
   let incfile = ref "tests.inc" in
   let is_native_available = ref false in
   C.main ~name:"tests"
@@ -61,4 +82,6 @@ let _ =
       "Name for the tests sexp output (default tests.inc)"
     ]
     (fun _ ->
-      write_content !incfile (List.concat (List.map (make_stanzas !is_native_available) testnames)))
+      let diff_tests = List.map (make_diff_stanzas !is_native_available) diff_testnames in
+      let nondiff_tests = List.map (make_nondiff_stanzas !is_native_available) nondiff_testnames in
+      write_content !incfile (List.concat [List.concat diff_tests; List.concat nondiff_tests]))

test/lib/dune

@@ -0,0 +1,24 @@
+(library
+ (name multicont_testlib)
+ (modes byte best)
+ (modules inspect_fiber)
+ (foreign_stubs
+  (language c)
+  (mode byte)
+  (flags :standard (:include c_byte_flags.sexp))
+  (names inspect_fiber_stubs))
+ (foreign_stubs
+  (language c)
+  (mode native)
+  (flags :standard (:include c_native_flags.sexp))
+  (names inspect_fiber_stubs)))
+
+(rule
+ (targets c_byte_flags.sexp c_native_flags.sexp)
+ (action (run ../../config/configure.exe)))
+
+(executable
+ (name unique_fibers)
+ (modes byte_complete native)
+ (modules unique_fibers)
+ (libraries multicont multicont_testlib))

test/lib/inspect_fiber.ml

@@ -0,0 +1,2 @@
+type fiber
+external fiber_id : fiber -> Int64.t = "multicont_test_lib_fiber_id"

test/lib/inspect_fiber_stubs.c

@@ -0,0 +1,24 @@
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h> // provides basic CAML macros and type definitions
+#include <caml/fail.h>     // provides [caml_raise_out_of_memory]
+#include <caml/alloc.h>    // provides [caml_alloc_1]
+#include <caml/fiber.h>    // provides Stack_* macros, [struct stack_info]
+#include <caml/memory.h>   // provides CAMLparam* and CAMLreturn* macros
+#include <caml/misc.h>     // provides [CAMLnoalloc] macro
+#include <caml/version.h>  // provides OCaml versioning macros
+
+#ifdef NATIVE_CODE
+#include <caml/stack.h>
+#include <caml/frame_descriptors.h>
+#endif
+
+CAMLextern value caml_copy_int64 (int64_t); // defined in [ocaml/runtime/ints.c]
+
+CAMLprim value multicont_test_lib_fiber_id(value fiber) {
+  CAMLparam1(fiber);
+  CAMLlocal1(id);
+  struct stack_info *stack = Ptr_val(Field(fiber, 0));
+  id = caml_copy_int64(stack->id);
+  CAMLreturn(id);
+}

test/lib/unique_fibers.ml

@@ -0,0 +1,32 @@
+open Effect.Deep
+open Multicont.Deep
+
+type _ Effect.t += Clone : unit Effect.t
+
+let test unique_fibers_enabled =
+  let result = ref [] in
+  match_with Effect.perform Clone
+    { retc = (fun _ -> ())
+    ; exnc = raise
+    ; effc = (fun (type a) (eff : a Effect.t) ->
+      match eff with
+      | Clone -> Some (fun (k : (a, _) continuation) ->
+                     let open Multicont_testlib.Inspect_fiber in
+                     let k' = clone_continuation k in
+                     (* NOTE(dhil): The fiber and continuation
+                        representation is the same for deep and
+                        shallow continuations. *)
+                     result := [ fiber_id (Obj.magic k)
+                               ; fiber_id (Obj.magic k')])
+      | _ -> None ) };
+  match !result with
+  | [original_id; clone_id] when unique_fibers_enabled ->
+     assert (not (Int64.equal original_id clone_id))
+  | [original_id; clone_id] when not unique_fibers_enabled ->
+     assert (Int64.equal original_id clone_id)
+  | _ -> assert false
+
+let _ =
+  match Sys.getenv_opt "TEST_UNIQUE_FIBERS" with
+  | Some "true" -> test true
+  | _ -> test false