Merge 5.2.0minus-29 (oxcaml#212)

* Import ocaml sources for oxcaml/oxcaml@977afdd4ebd

* Automatic merges

* Commit conflicts

* Resolve trivial conflicts

* Resolve trivial type errors

* Fix remaining errors

* Bump magic numbers

* Promote tests and fix some issues

* Bump bootstrap compiler for flambda on github

* Fix formatting

* Import ocaml sources for oxcaml/oxcaml@0a1dc8de0264

* Automatic merges

* Fixup jkind printing

* Add flags

* Import ocaml sources for oxcaml/oxcaml@4ac226a124a5

* Commit conflicts

* Resolve conflicts

* Update version name

* Promote tests

Author: liam923

.github/workflows/flambda-backend.yml

@@ -72,9 +72,9 @@ jobs:
       if: steps.cache.outputs.cache-hit != 'true'
       working-directory: flambda-backend
       run: |
-        opam switch create 4.14.0 --yes
-        opam switch link 4.14.0 --yes
-        opam install --yes dune.3.19.1 menhir.20231231
+        opam switch create 5.4.0 --yes
+        opam switch link 5.4.0 --yes
+        opam install --yes dune.3.20.2 menhir.20231231
 
     - name: Configure, build, and install flambda-backend
       if: steps.cache.outputs.cache-hit != 'true'

src/analysis/completion.ml

@@ -136,7 +136,7 @@ let classify_node = function
   | Open_declaration _ -> `Module
   | Include_declaration _ -> `Module
   | Include_description _ -> `Module
-  | Mode _ | Modality _ ->
+  | Mode _ | Modality _ | Mod_bound _ ->
     (* CR-someday: Have proper completion for modes and modalities *)
     `Expression
   | Jkind_annotation _ ->

src/analysis/construct.ml

@@ -223,11 +223,11 @@ module Gen = struct
     | Mty_signature sig_items ->
       let env = Env.add_signature sig_items env in
       Mod.structure @@ structure env sig_items
-    | Mty_functor (param, out) ->
+    | Mty_functor (param, out, _) ->
       let param =
         match param with
         | Unit -> Parsetree.Unit
-        | Named (id, in_) ->
+        | Named (id, in_, _) ->
           Parsetree.Named
             ( Location.mknoloc (Option.map ~f:Ident.name id),
               Ptyp_of_type.module_type in_,
@@ -524,7 +524,7 @@ module Gen = struct
                   val_loc = Location.none;
                   val_attributes = [];
                   val_zero_alloc = Zero_alloc.default;
-                  val_modalities = Mode.Modality.id;
+                  val_modalities = Mode.Modality.(of_const Const.id);
                   val_uid = Uid.mk ~current_unit:(Env.get_unit_name ())
                 }
               in

src/analysis/context.ml

@@ -122,7 +122,7 @@ let inspect_expression ~cursor ~lid e : t =
         Constructor (cd, lid_loc.loc)
       else Module_path
     else Module_path
-  | Texp_ident (p, lid_loc, _, _, _) ->
+  | Texp_ident (p, lid_loc, _, _, _, _) ->
     let name = Path.last p in
     log ~title:"inspect_context" "name is: [%s]" name;
     if name = "*type-error*" then

src/analysis/destruct.ml

@@ -308,7 +308,7 @@ let rec get_every_pattern loc = function
       (* We are still in the same branch, going up. *)
       get_every_pattern loc parents
     | Expression
-        { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _, _, _); _ }
+        { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _, _, _, _); _ }
       when Ident.name id = "*type-error*" -> raise Ill_typed
     | Expression { exp_desc = Typedtree.Texp_function { params; _ }; _ } ->
     begin

src/analysis/inlay_hints.ml

@@ -13,7 +13,7 @@ let pattern_has_constraint (type a) (pattern : a Typedtree.general_pattern) =
       | Typedtree.Tpat_constraint _ -> true
       | Typedtree.Tpat_type (_, _)
       | Typedtree.Tpat_open (_, _, _)
-      | Typedtree.Tpat_unpack -> false)
+      | Typedtree.Tpat_unpack | Typedtree.Tpat_inspected_type _ -> false)
     pattern.pat_extra
 
 let structure_iterator hint_let_binding hint_pattern_binding

src/analysis/kind_enclosing.ml

@@ -15,12 +15,13 @@ module Kind_info = struct
         kind
     in
     Printtyp.wrap_printing_env ~verbosity env (fun () ->
-        let format_jkind =
-          match Mconfig.Verbosity.to_int ~for_smart:0 verbosity > 0 with
-          | false -> Jkind.format
-          | true -> Jkind.format_expanded
+        let verbosity : Jkind.Format_verbosity.t =
+          match Mconfig.Verbosity.to_int ~for_smart:0 verbosity with
+          | 0 -> Not_verbose
+          | 1 -> Expanded
+          | _ -> Expanded_with_all_mod_bounds
         in
-        Format.asprintf "%a" format_jkind kind)
+        Format.asprintf "%a" (Jkind.format_verbose ~verbosity) kind)
 end
 
 let loc_contains_cursor (loc : Location.t) ~cursor =

src/analysis/ptyp_of_type.ml

@@ -17,18 +17,18 @@ let rec module_type =
     Ast_helper.Mty.ident (Location.mknoloc (Untypeast.lident_of_path path))
   | Mty_alias path ->
     Ast_helper.Mty.alias (Location.mknoloc (Untypeast.lident_of_path path))
-  | Mty_functor (param, type_out) ->
+  | Mty_functor (param, type_out, ret_mode) ->
     let param =
       match param with
       | Unit -> Parsetree.Unit
-      | Named (id, type_in) ->
+      | Named (id, type_in, param_mode) ->
         Parsetree.Named
           ( Location.mknoloc (Option.map ~f:Ident.name id),
             module_type type_in,
-            [] )
+            modes param_mode )
     in
     let out = module_type type_out in
-    Mty.functor_ param out
+    Mty.functor_ ~ret_mode:(modes ret_mode) param out
   | Mty_strengthen (mty, path, _aliasability) ->
     Mty.strengthen ~loc:Location.none (module_type mty)
       (Location.mknoloc (Untypeast.lident_of_path path))
@@ -55,16 +55,8 @@ and core_type type_expr =
       | Labelled l -> (Labelled l, core_type type_expr)
       | Optional l -> (Optional l, core_type type_expr)
     in
-    let snap = Btype.snapshot () in
-    let arg_modes =
-      Typemode.untransl_mode_annots
-      @@ Mode.Alloc.(Const.diff (zap_to_legacy arg_alloc_mode) Const.legacy)
-    in
-    let ret_modes =
-      Typemode.untransl_mode_annots
-      @@ Mode.Alloc.(Const.diff (zap_to_legacy ret_alloc_mode) Const.legacy)
-    in
-    Btype.backtrack snap;
+    let arg_modes = modes arg_alloc_mode in
+    let ret_modes = modes ret_alloc_mode in
     Typ.arrow label type_expr (core_type type_expr_out) arg_modes ret_modes
   | Ttuple type_exprs ->
     let labeled_type_exprs =
@@ -158,8 +150,17 @@ and extension_constructor id { ext_args; ext_ret_type; ext_attributes; _ } =
     ?res:(Option.map ~f:core_type ext_ret_type)
     (var_of_id id)
 
-and const_modalities modalities =
-  Typemode.untransl_modalities Immutable modalities
+and modes mode =
+  let snapshot = Btype.snapshot () in
+  let mode = Mode.Alloc.zap_to_legacy mode in
+  Btype.backtrack snapshot;
+  Printtyp.tree_of_modes mode
+  |> List.map ~f:(fun mode -> Location.mknoloc (Parsetree.Mode mode))
+
+and const_modalities ~mut modality =
+  Printtyp.tree_of_modalities mut modality
+  |> List.map ~f:(fun modality ->
+         Location.mknoloc (Parsetree.Modality modality))
 
 and value_description id
     { val_type; val_kind = _; val_loc; val_attributes; val_modalities; _ } =
@@ -171,14 +172,14 @@ and value_description id
     pval_type = type_;
     pval_prim = [];
     pval_attributes = val_attributes;
-    pval_modalities = const_modalities modalities;
+    pval_modalities = const_modalities ~mut:Immutable modalities;
     pval_loc = val_loc
   }
 
 and constructor_argument { ca_type; ca_loc; ca_modalities; ca_sort = _ } =
   { Parsetree.pca_type = core_type ca_type;
     pca_loc = ca_loc;
-    pca_modalities = const_modalities ca_modalities
+    pca_modalities = const_modalities ~mut:Immutable ca_modalities
   }
 
 and label_declaration
@@ -188,7 +189,7 @@ and label_declaration
       (match ld_mutable with
       | Mutable _ -> Mutable
       | Immutable -> Immutable)
-    ~modalities:(Typemode.untransl_modalities ld_mutable ld_modalities)
+    ~modalities:(const_modalities ~mut:ld_mutable ld_modalities)
     (var_of_id ld_id) (core_type ld_type)
 
 and constructor_arguments = function

src/analysis/signature_help.ml

@@ -27,7 +27,7 @@ let extract_ident (exp_desc : Typedtree.expression_desc) =
     | Lapply (p1, p2) -> Format.fprintf ppf "%a(%a)" longident p1 longident p2
   in
   match exp_desc with
-  | Texp_ident (_, { txt = li; _ }, _, _, _) ->
+  | Texp_ident (_, { txt = li; _ }, _, _, _, _) ->
     let ppf, to_string = Format.to_string () in
     longident ppf li;
     Some (to_string ())

src/analysis/syntax_doc.ml

@@ -200,13 +200,8 @@ let get_mod_bound_doc mod_bound =
      }
     : syntax_info)
 
-let get_mode_doc mode =
+let get_mode_doc (Atom (axis, mode) : Mode.Alloc.atom) =
   let open Option.Infix in
-  let* (P (axis, mode)) =
-    match Typemode.Mode_axis_pair.of_string mode with
-    | exception Not_found -> None
-    | res -> Some res
-  in
   let* description =
     match (axis, mode) with
     | Comonadic Areality, Local ->
@@ -291,27 +286,23 @@ let get_mode_doc mode =
      { name = "Mode"; description; documentation = doc_url; level = Advanced }
     : syntax_info)
 
-let get_modality_doc modality =
-  let open Option.Infix in
-  let* (P (axis, _)) =
-    match Typemode.Modality_axis_pair.of_string modality with
-    | exception Not_found -> None
-    | res -> Some res
-  in
+let get_modality_doc (Atom (axis, modality) : Mode.Modality.atom) =
   let description =
     (* CR-someday: Detect the context that the modality is within to make this message
        more detailed. Ex: "This field is always stronger than _, even if the record has a
        weaker mode." *)
     match axis with
     | Comonadic _ ->
       Format.asprintf
-        "The annotated value's mode is always at least as strong as `%s`, even \
+        "The annotated value's mode is always at least as strong as `%a`, even \
          if its container's mode is weaker."
+        (Mode.Modality.Per_axis.print axis)
         modality
     | Monadic _ ->
       Format.asprintf
-        "The annotated value's mode is always at least as weak as `%s`, even \
+        "The annotated value's mode is always at least as weak as `%a`, even \
          if its container's mode is a stronger."
+        (Mode.Modality.Per_axis.print axis)
         modality
   in
   (Some
@@ -644,17 +635,15 @@ let get_oxcaml_syntax_doc cursor_loc nodes : syntax_info =
   in
   match nodes with
   (* Modes and modalities *)
-  | Mode { txt = Mode mode; _ } :: ancestors -> (
-    match ancestors with
-    | Jkind_annotation _ :: _ -> get_mod_bound_doc mode
-    | _ -> get_mode_doc mode)
-  | Modality { txt = Modality modality; _ } :: ancestors -> (
+  | Mode { txt = mode; _ } :: _ -> get_mode_doc mode
+  | Modality { txt = modality; _ } :: ancestors -> (
     match ancestors with
     | Jkind_annotation _ :: _ ->
       (* CR-someday: Provide separate documatation for modalities within a jkind *)
       get_modality_doc modality
     | _ -> get_modality_doc modality)
   (* Jkinds *)
+  | Mod_bound { txt = Mode mod_bound; _ } :: _ -> get_mod_bound_doc mod_bound
   | Jkind_annotation { pjkind_desc = Pjk_abbreviation abbrev; _ } :: _ ->
     get_jkind_abbrev_doc abbrev
   | Jkind_annotation { pjkind_desc = Pjk_mod _; _ } :: _ ->
@@ -813,7 +802,8 @@ let get_syntax_doc cursor_loc node : syntax_info =
     :: ( _,
          Module_type_constraint
            (Tmodtype_explicit
-             { mty_desc = Tmty_with (_, [ (_, _, Twith_modtype _) ]); _ }) )
+             ({ mty_desc = Tmty_with (_, [ (_, _, Twith_modtype _) ]); _ }, _))
+       )
     :: _ ->
     Some
       { name = "Module substitution";