Support using landmarks with OCaml 5 domains

README.md

@@ -294,6 +294,16 @@ in the landmarks-threads.cm(x)a archive) that prevents non thread-safe
 functions to execute in all threads but the one which started the
 profiling.
 
+Instrumenting with domains (on OCaml >= 5)
+------------------------------------------
+
+*Landmarks* can be used with OCaml domains, but it comes with the following
+constraints:
+
+1) Each domain has to run on its separate physical core, notably for correct
+   time measures (which can be done using [ocaml-processor](https://github.com/haesbaert/ocaml-processor) or [domainpc](https://github.com/OCamlPro/domainpc)).
+2) Spawned domains have to terminate before the main domain.
+
 Known Issue
 -----------
 

dune-project

@@ -34,7 +34,7 @@
 landmarks library.")
  (depends
   (ocaml (>= 4.08))
-  (ppxlib (>= 0.22))
+  (ppxlib (>= 0.36))
   (landmarks (= 1.5))
  )
 )

landmarks-ppx.opam

@@ -13,7 +13,7 @@ bug-reports: "https://github.com/LexiFi/landmarks/issues"
 depends: [
   "dune" {>= "3.16"}
   "ocaml" {>= "4.08"}
-  "ppxlib" {>= "0.22"}
+  "ppxlib" {>= "0.36"}
   "landmarks" {= "1.5"}
   "odoc" {with-doc}
 ]

ppx/mapper.ml

@@ -176,26 +176,47 @@ let wrap_landmark ctx landmark loc expr =
 
 let rec arity {pexp_desc; _} =
   match pexp_desc with
-  | Pexp_fun (a, _, _, e) -> a :: arity e
-  | Pexp_function cases ->
-      let max_list l1 l2 =
-        if List.length l1 < List.length l2 then
-          l1
-        else
-          l2
-      in
-      Nolabel :: (List.fold_left
-                    (fun acc {pc_rhs; _} -> max_list (arity pc_rhs) acc)
-                    [] cases)
+  | Pexp_function (params, _, body) ->
+    List.filter_map
+      (function
+        | { pparam_desc = Pparam_val (a, _, _); _ } -> Some a
+        | { pparam_desc = Pparam_newtype _; _ } -> None )
+      params
+    @ body_arity body
   | Pexp_newtype (_, e) -> arity e
   | Pexp_constraint (e, _) -> arity e
   | Pexp_poly (e, _) -> arity e
   | _ -> []
 
-let rec wrap_landmark_method ctx landmark loc ({pexp_desc; _} as expr) =
+and body_arity body =
+  match body with
+  | Pfunction_body e -> arity e
+  | Pfunction_cases (cases, _, _) ->
+    let max_list l1 l2 = if List.length l1 < List.length l2 then l1 else l2 in
+    Nolabel
+    :: List.fold_left
+         (fun acc { pc_rhs; _ } -> max_list (arity pc_rhs) acc)
+         [] cases
+
+let rec wrap_landmark_method ctx landmark loc ({ pexp_desc; _ } as expr) =
   match pexp_desc with
-  | Pexp_fun (label, def, pat, e) ->
-      { expr with pexp_desc = Pexp_fun (label, def, pat, wrap_landmark_method ctx landmark loc e)}
+  | Pexp_function (params, constraint_, Pfunction_body e) ->
+    let body = wrap_landmark_method ctx landmark loc e in
+    { expr with
+      pexp_desc = Pexp_function (params, constraint_, Pfunction_body body)
+    }
+  | Pexp_function ((_ :: _ as params), constraint_, Pfunction_cases (c, l, a))
+    ->
+    let function_ =
+      { expr with
+        pexp_desc = Pexp_function ([], None, Pfunction_cases (c, l, a))
+      ; pexp_loc = l
+      }
+    in
+    let body = wrap_landmark ctx landmark l function_ in
+    { expr with
+      pexp_desc = Pexp_function (params, constraint_, Pfunction_body body)
+    }
   | Pexp_poly (e, typ) ->
       { expr with pexp_desc = Pexp_poly (wrap_landmark_method ctx landmark loc e, typ)}
   | _ -> wrap_landmark ctx landmark loc expr
@@ -256,10 +277,10 @@ let translate_value_bindings ctx value_binding auto vbs =
   in
   let vbs = List.map (function
       | (vb, None) -> value_binding vb
-      | {pvb_pat; pvb_loc; pvb_expr; _}, Some (arity, _, name, loc, attrs) ->
+      | {pvb_pat; pvb_loc; pvb_expr; pvb_constraint; _}, Some (arity, _, name, loc, attrs) ->
           (* Remove landmark attribute: *)
           let vb =
-            Vb.mk ~attrs ~loc:pvb_loc pvb_pat pvb_expr
+            Vb.mk ~attrs ~loc:pvb_loc ?value_constraint:pvb_constraint pvb_pat pvb_expr
             |> value_binding
           in
           if arity = [] then

src/dune

@@ -1,6 +1,7 @@
 (library
  (name landmark)
  (public_name landmarks)
+ (modules landmark landmark_state graph misc utils)
  (no_dynlink)
  (flags
   (:standard -w +A-30-42-41-40-4-70 -safe-string -strict-sequence))
@@ -10,3 +11,19 @@
  (js_of_ocaml (javascript_files utils.js))
  (instrumentation.backend
   (ppx landmarks-ppx)))
+
+(rule
+ (targets landmark_state.ml)
+ (deps landmark_state_ocaml4.ml)
+ (action
+  (copy# %{deps} %{targets}))
+ (enabled_if
+  (< %{ocaml_version} 5.0.0)))
+
+(rule
+ (targets landmark_state.ml)
+ (deps landmark_state_ocaml5.ml)
+ (action
+  (copy# %{deps} %{targets}))
+ (enabled_if
+  (>= %{ocaml_version} 5.0.0)))