Add tentative support for OCaml 5.3

The cmt format has changed, this tries to support value dependencies just based on the type of what's available in the new `Cmt_format.cmt_infos`.

#202

Author: cristianoc

.github/workflows/ci.yml

@@ -60,6 +60,10 @@ jobs:
             target: ocaml.5.2
             ocaml-compiler: 5.2.x
             build: opam exec -- dune build
+          - os: ubuntu-latest
+            target: ocaml.5.3
+            ocaml-compiler: 5.3.x
+            build: opam exec -- dune build
 
     runs-on: ${{matrix.os}}
 

src/Annotation.ml

@@ -20,10 +20,13 @@ let tagIsOneOfTheGenTypeAnnotations s =
 let rec getAttributePayload checkText (attributes : CL.Typedtree.attributes) =
   let rec fromExpr (expr : CL.Parsetree.expression) =
     match expr with
-    | {pexp_desc = Pexp_constant (Pconst_string _ as cs)} ->
-      Some (StringPayload (cs |> Compat.getStringValue))
-    | {pexp_desc = Pexp_constant (Pconst_integer (n, _))} -> Some (IntPayload n)
-    | {pexp_desc = Pexp_constant (Pconst_float (s, _))} -> Some (FloatPayload s)
+    | { pexp_desc = Pexp_constant c} ->
+      let desc = Compat.constant_desc c in
+      (match desc with
+      | Pconst_string _ -> Some (StringPayload (desc |> Compat.getStringValue))
+      | Pconst_integer (n, _) -> Some (IntPayload n)
+      | Pconst_float (s, _) -> Some (FloatPayload s)
+      | _ -> None)
     | {
      pexp_desc = Pexp_construct ({txt = Lident (("true" | "false") as s)}, _);
      _;

src/Arnold.ml

@@ -906,7 +906,8 @@ module Compile = struct
     | Texp_tuple expressions | Texp_array expressions ->
       expressions |> List.map (expression ~ctx) |> Command.unorderedSequence
     | Texp_assert _ -> Command.nothing
-    | Texp_try (e, cases) ->
+    | Texp_try _ ->
+      let e, cases = expr.exp_desc |> Compat.getTexpTry in
       let cE = e |> expression ~ctx in
       let cCases = cases |> List.map (case ~ctx) |> Command.nondet in
       let open Command in

src/Compat.ml

@@ -174,7 +174,10 @@ let getMtyFunctorModuleType  (moduleType: Types.module_type) = match moduleType
   | _ -> None
 
 let getTexpMatch desc = match desc with
-#if OCAML_VERSION >= (4, 08, 0)
+#if OCAML_VERSION >= (5, 3, 0)
+  | Typedtree.Texp_match(e, cases, _values, partial) ->
+    (e, cases, partial)
+#elif OCAML_VERSION >= (4, 08, 0)
   | Typedtree.Texp_match(e, cases, partial) ->
     (e, cases, partial)
 #else
@@ -183,8 +186,26 @@ let getTexpMatch desc = match desc with
 #endif
   | _ -> assert false
 
+let getTexpTry desc = match desc with
+#if OCAML_VERSION >= (5, 3, 0)
+  | Typedtree.Texp_try(e, cases, _values) ->
+    (e, cases)
+#else
+  | Typedtree.Texp_try(e, cases) ->
+    (e, cases)
+#endif
+  | _ -> assert false
+
 let texpMatchGetExceptions desc = match desc with
-#if OCAML_VERSION >= (4, 08, 0)
+#if OCAML_VERSION >= (5, 3, 0)
+  | Typedtree.Texp_match(_, cases, _, _) ->
+    cases
+    |> List.filter_map(fun ({Typedtree.c_lhs= pat}) ->
+          match pat.pat_desc with
+          | Tpat_exception({pat_desc}) -> Some(pat_desc)
+          | _ -> None
+          )
+#elif OCAML_VERSION >= (4, 08, 0)
   | Typedtree.Texp_match(_, cases, _) ->
     cases
     |> List.filter_map(fun ({Typedtree.c_lhs= pat}) ->
@@ -241,3 +262,29 @@ let get_desc = Types.get_desc
 #else
 let get_desc x = x.Types.desc
 #endif
+
+let constant_desc d =
+#if OCAML_VERSION >= (5, 3, 0)
+  d.Parsetree.pconst_desc
+#else
+  d
+#endif
+
+let extractValueDependencies (cmt_infos : CL.Cmt_format.cmt_infos) =
+#if OCAML_VERSION >= (5, 3, 0)
+  let deps = ref [] in
+  let process_dependency (_, uid1, uid2) =
+    match
+      ( Types.Uid.Tbl.find_opt cmt_infos.cmt_uid_to_decl uid1,
+        Types.Uid.Tbl.find_opt cmt_infos.cmt_uid_to_decl uid2 )
+    with
+    | Some (Value v1), Some (Value v2) ->
+      deps := (v1.val_val, v2.val_val) :: !deps
+    | _ -> ()
+  in
+  let items = cmt_infos.cmt_declaration_dependencies in
+  List.iter process_dependency items;
+  List.rev !deps
+#else
+  cmt_infos.cmt_value_dependencies
+#endif

src/DeadCode.ml

@@ -25,8 +25,9 @@ let processCmt ~cmtFilePath (cmt_infos : CL.Cmt_format.cmt_infos) =
          Ideally, the handling should be less location-based, just like other language aspects. *)
       false
     in
+    let cmt_value_dependencies = Compat.extractValueDependencies cmt_infos in
     DeadValue.processStructure ~doTypes:true ~doExternals
-      ~cmt_value_dependencies:cmt_infos.cmt_value_dependencies structure
+      ~cmt_value_dependencies structure
   | _ -> ());
   DeadType.TypeDependencies.forceDelayedItems ();
   DeadType.TypeDependencies.clear ()

src/Exception.ml

@@ -351,7 +351,8 @@ let traverseAst () =
             kind = Raises;
           }
           :: !currentEvents
-    | Texp_try (e, cases) ->
+    | Texp_try _ ->
+      let e, cases = expr.exp_desc |> Compat.getTexpTry in
       let exceptions =
         cases
         |> List.map (fun case -> case.CL.Typedtree.c_lhs.pat_desc)

src/SideEffects.ml

@@ -46,7 +46,8 @@ let rec exprNoSideEffects (expr : CL.Typedtree.expression) =
     && cases |> List.for_all caseNoSideEffects
   | Texp_letmodule _ -> false
   | Texp_lazy e -> e |> exprNoSideEffects
-  | Texp_try (e, cases) ->
+  | Texp_try _ ->
+    let e, cases = expr.exp_desc |> Compat.getTexpTry in
     e |> exprNoSideEffects && cases |> List.for_all caseNoSideEffects
   | Texp_tuple el -> el |> List.for_all exprNoSideEffects
   | Texp_variant (_lbl, eo) -> eo |> exprOptNoSideEffects