Upgrade to 5.1.1: use compiler-libs' compression functions (ocaml#1714)

from voodoos/5.1.1-upgrade

.github/workflows/main.yml

@@ -40,7 +40,7 @@ jobs:
           - ubuntu-latest
           # - windows-latest
         ocaml-compiler:
-          - "5.1"
+          - "5.1.1"
     # The type of runner that the job will run on
     runs-on: ${{ matrix.os }}
 

CHANGES.md

@@ -1,5 +1,5 @@
-merlin 4.13
-===========
+merlin 4.13.1
+=============
 Fri Dec  1 15:00:42 CET 2023
 
   + merlin binary
@@ -12,6 +12,7 @@ Fri Dec  1 15:00:42 CET 2023
       (@goldfirere, #1699)
     - Fix Merlin reporting errors provoked by the recovery itself (#1709, fixes
       #1704)
+    - Add support for OCaml 5.1.1 (#1714)
   + editor modes
     - vim: load merlin when Vim is compiled with +python3/dyn (e.g. MacVim)
     - emacs: highlight only first error line by default (#1693, fixes #1663)

merlin-lib.opam

@@ -10,7 +10,7 @@ build: [
   ["dune" "build" "-p" name "-j" jobs]
 ]
 depends: [
-  "ocaml" {>= "5.1" & < "5.2"}
+  "ocaml" {>= "5.1.1" & < "5.2"}
   "dune" {>= "2.9.0"}
   "csexp" {>= "1.5.1"}
   "menhir"    {dev & >= "20201216"}

src/ocaml/compression/dune

@@ -0,0 +1,4 @@
+(library
+ (name ocaml_compression)
+ (public_name merlin-lib.ocaml_compression)
+ (libraries compiler-libs.common))

src/ocaml/compression/ocaml_compression.ml

@@ -0,0 +1,3 @@
+
+(** We rely on [compiler-libs] for compression *)
+include Compression

src/ocaml/typing/cmi_format.ml

@@ -35,7 +35,7 @@ type cmi_infos = {
 }
 
 let input_cmi ic =
-  let (name, sign) = (input_value ic : header) in
+  let (name, sign) = (Ocaml_compression.input_value ic : header) in
   let crcs = (input_value ic : crcs) in
   let flags = (input_value ic : flags) in
   {
@@ -76,7 +76,7 @@ let read_cmi filename =
 let output_cmi filename oc cmi =
 (* beware: the provided signature must have been substituted for saving *)
   output_string oc Config.cmi_magic_number;
-  output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header);
+  Ocaml_compression.output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header);
   flush oc;
   let crc = Digest.file filename in
   let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in

src/ocaml/typing/cmt_format.ml

@@ -121,11 +121,11 @@ let clear_env binary_annots =
 
 exception Error of error
 
-let input_cmt ic = (input_value ic : cmt_infos)
+let input_cmt ic = (Ocaml_compression.input_value ic : cmt_infos)
 
 let output_cmt oc cmt =
   output_string oc Config.cmt_magic_number;
-  output_value oc (cmt : cmt_infos)
+  Ocaml_compression.output_value oc (cmt : cmt_infos)
 
 let read filename =
 (*  Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)

src/ocaml/typing/dune

@@ -7,4 +7,4 @@
    -open Merlin_utils
    (:standard -w -9))
   (modules_without_implementation annot outcometree)
-  (libraries merlin_utils ocaml_parsing ocaml_utils))
+  (libraries merlin_utils ocaml_compression ocaml_parsing ocaml_utils))

src/ocaml/typing/typedecl.ml

@@ -98,7 +98,12 @@ let add_type ~long_path ~check id decl env =
        | true -> Env.add_type_long_path ~check id decl env
        | false -> Env.add_type ~check id decl env)
 
-let enter_type rec_flag env sdecl (id, uid) =
+(* Add a dummy type declaration to the environment, with the given arity.
+   The [type_kind] is [Type_abstract], but there is a generic [type_manifest]
+   for abbreviations, to allow polymorphic expansion, except if
+   [abstract_abbrevs] is [true].
+   This function is only used in [transl_type_decl]. *)
+let enter_type ~abstract_abbrevs rec_flag env sdecl (id, uid) =
   let needed =
     match rec_flag with
     | Asttypes.Nonrecursive ->
@@ -114,15 +119,17 @@ let enter_type rec_flag env sdecl (id, uid) =
   in
   let arity = List.length sdecl.ptype_params in
   if not needed then env else
+  let type_manifest = match sdecl.ptype_manifest, abstract_abbrevs with
+    | None, _ | Some _, true -> None
+    | Some _, false -> Some(Ctype.newvar ())
+  in
   let decl =
     { type_params =
         List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
       type_arity = arity;
       type_kind = Type_abstract;
       type_private = sdecl.ptype_private;
-      type_manifest =
-        begin match sdecl.ptype_manifest with None -> None
-        | Some _ -> Some(Ctype.newvar ()) end;
+      type_manifest;
       type_variance = Variance.unknown_signature ~injective:false ~arity;
       type_separability = Types.Separability.default_signature ~arity;
       type_is_newtype = false;
@@ -789,7 +796,7 @@ let check_abbrev env sdecl (id, decl) =
    - if -rectypes is not used, we only allow cycles in the type graph
      if they go through an object or polymorphic variant type *)
 
-let check_well_founded env loc path to_check visited ty0 =
+let check_well_founded ~abs_env env loc path to_check visited ty0 =
   let rec check parents trace ty =
     if TypeSet.mem ty parents then begin
       (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
@@ -805,8 +812,8 @@ let check_well_founded env loc path to_check visited ty0 =
           | trace -> List.rev trace, false
         in
         if rec_abbrev
-        then Recursive_abbrev (Path.name path, env, reaching_path)
-        else Cycle_in_def (Path.name path, env, reaching_path)
+        then Recursive_abbrev (Path.name path, abs_env, reaching_path)
+        else Cycle_in_def (Path.name path, abs_env, reaching_path)
       in raise (Error (loc, err))
     end;
     let (fini, parents) =
@@ -851,11 +858,11 @@ let check_well_founded env loc path to_check visited ty0 =
     (* Will be detected by check_regularity *)
     Btype.backtrack snap
 
-let check_well_founded_manifest env loc path decl =
+let check_well_founded_manifest ~abs_env env loc path decl =
   if decl.type_manifest = None then () else
   let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in
   let visited = ref TypeMap.empty in
-  check_well_founded env loc path (Path.same path) visited
+  check_well_founded ~abs_env env loc path (Path.same path) visited
     (Ctype.newconstr path args)
 
 (* Given a new type declaration [type t = ...] (potentially mutually-recursive),
@@ -873,7 +880,7 @@ let check_well_founded_manifest env loc path decl =
    (we don't have an example at hand where it is necessary), but we
    are doing it anyway out of caution.
 *)
-let check_well_founded_decl env loc path decl to_check =
+let check_well_founded_decl ~abs_env env loc path decl to_check =
   let open Btype in
   (* We iterate on all subexpressions of the declaration to check
      "in depth" that no ill-founded type exists. *)
@@ -892,7 +899,7 @@ let check_well_founded_decl env loc path decl to_check =
     {type_iterators with it_type_expr =
      (fun self ty ->
        if TypeSet.mem ty !checked then () else begin
-         check_well_founded env loc path to_check visited ty;
+         check_well_founded ~abs_env env loc path to_check visited ty;
          checked := TypeSet.add ty !checked;
          self.it_do_type_expr self ty
        end)} in
@@ -1080,7 +1087,8 @@ let transl_type_decl env rec_flag sdecl_list =
     Ctype.with_local_level_iter ~post:generalize_decl begin fun () ->
       (* Enter types. *)
       let temp_env =
-        List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in
+        List.fold_left2 (enter_type ~abstract_abbrevs:false rec_flag)
+          env sdecl_list ids_list in
       (* Translate each declaration. *)
       let current_slot = ref None in
       let warn_unused =
@@ -1137,14 +1145,23 @@ let transl_type_decl env rec_flag sdecl_list =
     List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc))
       ids_list sdecl_list
   in
+  (* Error messages cannot use the new environment, as this might result in
+     non-termination. Instead we use a completely abstract version of the
+     temporary environment, giving a reason for why abbreviations cannot be
+     expanded (#12645, #12649) *)
+  let abs_env =
+    List.fold_left2
+      (enter_type ~abstract_abbrevs:true rec_flag)
+      env sdecl_list ids_list in
   List.iter (fun (id, decl) ->
-    check_well_founded_manifest new_env (List.assoc id id_loc_list)
+    check_well_founded_manifest ~abs_env new_env (List.assoc id id_loc_list)
       (Path.Pident id) decl)
     decls;
   let to_check =
     function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in
   List.iter (fun (id, decl) ->
-    check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id)
+    check_well_founded_decl ~abs_env new_env (List.assoc id id_loc_list)
+      (Path.Pident id)
       decl to_check)
     decls;
   List.iter
@@ -1830,7 +1847,7 @@ let check_recmod_typedecl env loc recmod_ids path decl =
   (* recmod_ids is the list of recursively-defined module idents.
      (path, decl) is the type declaration to be checked. *)
   let to_check path = Path.exists_free recmod_ids path in
-  check_well_founded_decl env loc path decl to_check;
+  check_well_founded_decl ~abs_env:env env loc path decl to_check;
   check_regularity ~orig_env:env env loc path decl to_check;
   (* additionally check coherece, as one might build an incoherent signature,
      and use it to build an incoherent module, cf. #7851 *)

src/ocaml/typing/types.ml

@@ -185,7 +185,7 @@ module Variance = struct
     let mp =
       mem May_pos v1 && mem May_pos v2 || mem May_neg v1 && mem May_neg v2
     and mn =
-      mem May_pos v1 && mem May_neg v2 || mem May_pos v1 && mem May_neg v2
+      mem May_pos v1 && mem May_neg v2 || mem May_neg v1 && mem May_pos v2
     and mw = mem May_weak v1 && v2 <> null || v1 <> null && mem May_weak v2
     and inj = mem Inj v1 && mem Inj v2
     and pos = mem Pos v1 && mem Pos v2 || mem Neg v1 && mem Neg v2

upstream/ocaml_501/base-rev.txt

@@ -1 +1 @@
-5717a14d0e3dc2b0e41ab94b82977d5761f70ea2
+35fdd0226e2e05a1a8244ecfec780b563b23b59c

upstream/ocaml_501/file_formats/cmi_format.ml

@@ -42,7 +42,7 @@ type cmi_infos = {
 }
 
 let input_cmi ic =
-  let (name, sign) = (input_value ic : header) in
+  let (name, sign) = (Compression.input_value ic : header) in
   let crcs = (input_value ic : crcs) in
   let flags = (input_value ic : flags) in
   {
@@ -84,7 +84,7 @@ let read_cmi filename =
 let output_cmi filename oc cmi =
 (* beware: the provided signature must have been substituted for saving *)
   output_string oc Config.cmi_magic_number;
-  Marshal.(to_channel oc ((cmi.cmi_name, cmi.cmi_sign) : header) [Compression]);
+  Compression.output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header);
   flush oc;
   let crc = Digest.file filename in
   let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in

upstream/ocaml_501/file_formats/cmt_format.ml

@@ -105,11 +105,11 @@ let clear_env binary_annots =
 
 exception Error of error
 
-let input_cmt ic = (input_value ic : cmt_infos)
+let input_cmt ic = (Compression.input_value ic : cmt_infos)
 
 let output_cmt oc cmt =
   output_string oc Config.cmt_magic_number;
-  Marshal.(to_channel oc (cmt : cmt_infos) [Compression])
+  Compression.output_value oc (cmt : cmt_infos)
 
 let read filename =
 (*  Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)

upstream/ocaml_501/typing/typedecl.ml

@@ -95,7 +95,12 @@ let add_type ~check id decl env =
   Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
     (fun () -> Env.add_type ~check id decl env)
 
-let enter_type rec_flag env sdecl (id, uid) =
+(* Add a dummy type declaration to the environment, with the given arity.
+   The [type_kind] is [Type_abstract], but there is a generic [type_manifest]
+   for abbreviations, to allow polymorphic expansion, except if
+   [abstract_abbrevs] is [true].
+   This function is only used in [transl_type_decl]. *)
+let enter_type ~abstract_abbrevs rec_flag env sdecl (id, uid) =
   let needed =
     match rec_flag with
     | Asttypes.Nonrecursive ->
@@ -111,15 +116,17 @@ let enter_type rec_flag env sdecl (id, uid) =
   in
   let arity = List.length sdecl.ptype_params in
   if not needed then env else
+  let type_manifest = match sdecl.ptype_manifest, abstract_abbrevs with
+    | None, _ | Some _, true -> None
+    | Some _, false -> Some(Ctype.newvar ())
+  in
   let decl =
     { type_params =
         List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
       type_arity = arity;
       type_kind = Type_abstract;
       type_private = sdecl.ptype_private;
-      type_manifest =
-        begin match sdecl.ptype_manifest with None -> None
-        | Some _ -> Some(Ctype.newvar ()) end;
+      type_manifest;
       type_variance = Variance.unknown_signature ~injective:false ~arity;
       type_separability = Types.Separability.default_signature ~arity;
       type_is_newtype = false;
@@ -782,7 +789,7 @@ let check_abbrev env sdecl (id, decl) =
    - if -rectypes is not used, we only allow cycles in the type graph
      if they go through an object or polymorphic variant type *)
 
-let check_well_founded env loc path to_check visited ty0 =
+let check_well_founded ~abs_env env loc path to_check visited ty0 =
   let rec check parents trace ty =
     if TypeSet.mem ty parents then begin
       (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
@@ -798,8 +805,8 @@ let check_well_founded env loc path to_check visited ty0 =
           | trace -> List.rev trace, false
         in
         if rec_abbrev
-        then Recursive_abbrev (Path.name path, env, reaching_path)
-        else Cycle_in_def (Path.name path, env, reaching_path)
+        then Recursive_abbrev (Path.name path, abs_env, reaching_path)
+        else Cycle_in_def (Path.name path, abs_env, reaching_path)
       in raise (Error (loc, err))
     end;
     let (fini, parents) =
@@ -844,11 +851,11 @@ let check_well_founded env loc path to_check visited ty0 =
     (* Will be detected by check_regularity *)
     Btype.backtrack snap
 
-let check_well_founded_manifest env loc path decl =
+let check_well_founded_manifest ~abs_env env loc path decl =
   if decl.type_manifest = None then () else
   let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in
   let visited = ref TypeMap.empty in
-  check_well_founded env loc path (Path.same path) visited
+  check_well_founded ~abs_env env loc path (Path.same path) visited
     (Ctype.newconstr path args)
 
 (* Given a new type declaration [type t = ...] (potentially mutually-recursive),
@@ -866,7 +873,7 @@ let check_well_founded_manifest env loc path decl =
    (we don't have an example at hand where it is necessary), but we
    are doing it anyway out of caution.
 *)
-let check_well_founded_decl env loc path decl to_check =
+let check_well_founded_decl ~abs_env env loc path decl to_check =
   let open Btype in
   (* We iterate on all subexpressions of the declaration to check
      "in depth" that no ill-founded type exists. *)
@@ -885,7 +892,7 @@ let check_well_founded_decl env loc path decl to_check =
     {type_iterators with it_type_expr =
      (fun self ty ->
        if TypeSet.mem ty !checked then () else begin
-         check_well_founded env loc path to_check visited ty;
+         check_well_founded ~abs_env env loc path to_check visited ty;
          checked := TypeSet.add ty !checked;
          self.it_do_type_expr self ty
        end)} in
@@ -1073,7 +1080,8 @@ let transl_type_decl env rec_flag sdecl_list =
     Ctype.with_local_level_iter ~post:generalize_decl begin fun () ->
       (* Enter types. *)
       let temp_env =
-        List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in
+        List.fold_left2 (enter_type ~abstract_abbrevs:false rec_flag)
+          env sdecl_list ids_list in
       (* Translate each declaration. *)
       let current_slot = ref None in
       let warn_unused =
@@ -1130,14 +1138,23 @@ let transl_type_decl env rec_flag sdecl_list =
     List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc))
       ids_list sdecl_list
   in
+  (* Error messages cannot use the new environment, as this might result in
+     non-termination. Instead we use a completely abstract version of the
+     temporary environment, giving a reason for why abbreviations cannot be
+     expanded (#12645, #12649) *)
+  let abs_env =
+    List.fold_left2
+      (enter_type ~abstract_abbrevs:true rec_flag)
+      env sdecl_list ids_list in
   List.iter (fun (id, decl) ->
-    check_well_founded_manifest new_env (List.assoc id id_loc_list)
+    check_well_founded_manifest ~abs_env new_env (List.assoc id id_loc_list)
       (Path.Pident id) decl)
     decls;
   let to_check =
     function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in
   List.iter (fun (id, decl) ->
-    check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id)
+    check_well_founded_decl ~abs_env new_env (List.assoc id id_loc_list)
+      (Path.Pident id)
       decl to_check)
     decls;
   List.iter
@@ -1818,7 +1835,7 @@ let check_recmod_typedecl env loc recmod_ids path decl =
   (* recmod_ids is the list of recursively-defined module idents.
      (path, decl) is the type declaration to be checked. *)
   let to_check path = Path.exists_free recmod_ids path in
-  check_well_founded_decl env loc path decl to_check;
+  check_well_founded_decl ~abs_env:env env loc path decl to_check;
   check_regularity ~orig_env:env env loc path decl to_check;
   (* additionally check coherece, as one might build an incoherent signature,
      and use it to build an incoherent module, cf. #7851 *)

upstream/ocaml_501/typing/types.ml

@@ -186,7 +186,7 @@ module Variance = struct
     let mp =
       mem May_pos v1 && mem May_pos v2 || mem May_neg v1 && mem May_neg v2
     and mn =
-      mem May_pos v1 && mem May_neg v2 || mem May_pos v1 && mem May_neg v2
+      mem May_pos v1 && mem May_neg v2 || mem May_neg v1 && mem May_pos v2
     and mw = mem May_weak v1 && v2 <> null || v1 <> null && mem May_weak v2
     and inj = mem Inj v1 && mem Inj v2
     and pos = mem Pos v1 && mem Pos v2 || mem Neg v1 && mem Neg v2