Merge 5.2.0minus 3

import-added-ocaml-source-files.sh

@@ -7,23 +7,28 @@ cd "$(dirname "${BASH_SOURCE[0]}")"
 # Script arguments with their default values
 commitish=main
 repository=https://github.com/ocaml-flambda/flambda-backend
-subdirectory=ocaml
+subdirectory=.
+old_subdirectory=.
 
 function usage () {
   cat <<USAGE
-Usage: $0 [COMMITISH [REPO [SUBDIRECTORY]]]
+Usage: $0 [COMMITISH [REPO [SUBDIRECTORY [OLD_SUBDIRECTORY]]]]
 
 Fetches any new files that previously hadn't been imported. This ignores
 files outside of *directories* that were previously imported,
 so if a whole new directory is added, you may need to manually
 add the new file.
+
+See usage information for ./import-ocaml-source.sh for more info about
+the subdirectory arguments.
 USAGE
 }
 
-if [[ $# -le 3 ]]; then
+if [[ $# -le 4 ]]; then
   commitish="${1-$commitish}"
   repository="${2-$repository}"
   subdirectory="${3-$subdirectory}"
+  old_subdirectory="${4-$old_subdirectory}"
 else
   usage >&2
   exit 1
@@ -39,7 +44,7 @@ esac
 # First, fetch the new flambda-backend sources (which include ocaml-jst).
 
 function sorted_files_at_committish() {
-  git ls-tree -r --name-only "$1" | sort
+  git ls-tree -r --name-only "$1" "$2" | sed "s#^$2/##" | sort
 }
 
 git fetch "$repository" "$(cat upstream/ocaml_flambda/base-rev.txt)"
@@ -48,15 +53,15 @@ rev=$(git rev-parse FETCH_HEAD)
 
 function files_new_at_fetch_head() {
   comm -13 \
-    <(sorted_files_at_committish "$(cat upstream/ocaml_flambda/base-rev.txt)") \
-    <(sorted_files_at_committish FETCH_HEAD)
+    <(sorted_files_at_committish "$(cat upstream/ocaml_flambda/base-rev.txt)" "$old_subdirectory") \
+    <(sorted_files_at_committish FETCH_HEAD "$subdirectory")
 }
 
 function directories_from_previous_import() {
   comm -12 \
     <(cd src/ocaml; ls -d */) \
     <(cd upstream/ocaml_flambda; ls -d */) \
-  | xargs -n 1 printf "^$subdirectory/%s\n"
+  | xargs -n 1 printf "^%s\n"
 }
 
 files=$(files_new_at_fetch_head | grep -f <(directories_from_previous_import))
@@ -69,9 +74,9 @@ for file in $files; do
   case ${answer} in
     y|Y|"" )
       echo "Importing $file"
-      ocaml_flambda_file=upstream/ocaml_flambda/"${file#$subdirectory/}"
+      ocaml_flambda_file=upstream/ocaml_flambda/"${file}"
       git show "FETCH_HEAD:$file" > "$ocaml_flambda_file"
-      cp "$ocaml_flambda_file" src/$file
+      cp "$ocaml_flambda_file" src/ocaml/$file
       ;;
     * )
       echo "Skipping $file; run '$0' again in order to make a different decision"

import-ocaml-source.sh

@@ -4,11 +4,12 @@ cd "$(dirname "${BASH_SOURCE[0]}")"
 
 # Script arguments with their default values
 repository=https://github.com/ocaml-flambda/flambda-backend
-subdirectory=ocaml
+subdirectory=.
+old_subdirectory=.
 
 function usage () {
   cat <<USAGE
-Usage: $0 COMMITISH [REPO [SUBDIRECTORY]]
+Usage: $0 COMMITISH [REPO [SUBDIRECTORY [OLD_SUBDIRECTORY]]]
 
 Fetch the new compiler sources and patch Merlin to keep Merlin's local copies of
 things in sync.  By default, this will pull the COMMITISH branch from
@@ -22,6 +23,12 @@ This attempts to import new files from the compiler by running the
 try making matched pairs of files in this repository with the right names: one
 in "upstream/ocaml_flambda/", and one in "src/ocaml".  Then running the script
 will pull in the named file(s).
+
+The SUBDIRECTORY argument is useful when importing from a repository that buries
+the relevant compiler files inside a subdirectory. This used to be the case for
+flambda (files were under an "ocaml/" direcotry), although it is no longer the
+case. The OLD_SUBDIRECTORY argument is useful for when the directory structure
+has changed since the last import.
 USAGE
 }
 
@@ -47,9 +54,12 @@ else
   exit 1
 fi
 
-if [[ $# -le 3 ]]; then
+if [[ $# -le 4 ]]; then
   repository="${2-$repository}"
+  # Although the subdirectory arguments are probably no longer useful, it doesn't hurt
+  # to keep them around in case they ever are of use.
   subdirectory="${3-$subdirectory}"
+  old_subdirectory="${4-$old_subdirectory}"
 else
   usage >&2
   exit 1
@@ -68,7 +78,7 @@ old_base_rev="$(cat upstream/ocaml_flambda/base-rev.txt)"
 current_head="$(git symbolic-ref --short HEAD)"
 
 # First, add any files that have been added since the last import.
-./import-added-ocaml-source-files.sh "$commitish" "$repository" "$subdirectory"
+./import-added-ocaml-source-files.sh "$commitish" "$repository" "$subdirectory" "$old_subdirectory"
 
 # Then, fetch the new flambda-backend sources (which include ocaml-jst) and
 # copy into upstream/ocaml_flambda
@@ -77,7 +87,12 @@ rev=$(git rev-parse FETCH_HEAD)
 cd upstream/ocaml_flambda
 echo $rev > base-rev.txt
 for file in $(git ls-tree --name-only -r HEAD | grep -v base-rev.txt); do
-  git show "FETCH_HEAD:$subdirectory/$file" > "$file";
+  if [[ "$subdirectory" = "." ]]; then
+    git_file="$file"
+  else
+    git_file="$subdirectory/$file"
+  fi
+  git show "FETCH_HEAD:$git_file" > "$file"
 done
 git add -u .
 cd ../..

src/analysis/construct.ml

@@ -51,7 +51,7 @@ module Util = struct
             (Predef.path_bool, construct "false");
             (Predef.path_unit, construct "()");
             (Predef.path_exn, ident "exn");
-            (Predef.path_array, Ast_helper.Exp.array []);
+            (Predef.path_array, Ast_helper.Exp.array Mutable []);
             (Predef.path_nativeint, constant (Pconst_integer ("0", Some 'n')));
             (Predef.path_int32, constant (Pconst_integer ("0", Some 'l')));
             (Predef.path_int64, constant (Pconst_integer ("0", Some 'L')));

src/analysis/destruct.ml

@@ -575,13 +575,7 @@ module Conv = struct
         (* PR#7330 *)
         mkpat (Ppat_var nm)
       | Tpat_any | Tpat_var _ -> mkpat Ppat_any
-      | Tpat_constant c -> begin
-        match Untypeast.constant c with
-        | `Jane_syntax c ->
-          Jane_syntax.Layouts.pat_of (Lpat_constant c)
-            ~loc:!Ast_helper.default_loc
-        | `Parsetree c -> mkpat (Ppat_constant c)
-      end
+      | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c))
       | Tpat_alias (p, _, _, _, _) -> loop p
       | Tpat_tuple lst ->
         let lst = List.map ~f:(fun (lbl, p) -> (lbl, loop p)) lst in
@@ -617,17 +611,16 @@ module Conv = struct
         mkpat (Ppat_record (fields, Open))
       | Tpat_array (mut, _, lst) ->
         let lst = List.map ~f:loop lst in
-        begin
+        let mut : Asttypes.mutable_flag =
           match mut with
           | Mutable mode ->
             assert (
               Mode.Alloc.Comonadic.Const.eq mode
                 Mode.Alloc.Comonadic.Const.legacy);
-            mkpat (Ppat_array lst)
-          | Immutable ->
-            Jane_syntax.Immutable_arrays.pat_of ~loc:pat.pat_loc
-              (Iapat_immutable_array lst)
-        end
+            Mutable
+          | Immutable -> Immutable
+        in
+        mkpat (Ppat_array (mut, lst))
       | Tpat_lazy p -> mkpat (Ppat_lazy (loop p))
     in
     let ps = loop typed in

src/analysis/ppx_expand.ml

@@ -142,7 +142,8 @@ let get_ppxed_source ~ppxed_parsetree ~pos ppx_kind_with_attr :
     }
   | Sig_item _, attr_loc ->
     let exp =
-      Pprintast.signature Format.str_formatter (List.rev !signature);
+      Pprintast.signature Format.str_formatter
+        (Ast_helper.Sg.mk (List.rev !signature));
       Format.flush_str_formatter ()
     in
     { code = exp; attr_start = attr_loc.loc_start; attr_end = attr_loc.loc_end }

src/analysis/ptyp_of_type.ml

@@ -28,16 +28,18 @@ let rec module_type =
     let out = module_type type_out in
     Mty.functor_ param out
   | Mty_strengthen (mty, path, _aliasability) ->
-    Jane_syntax.Strengthen.mty_of ~loc:Location.none
-      { mty = module_type mty;
-        mod_id = Location.mknoloc (Untypeast.lident_of_path path)
-      }
+    Mty.strengthen ~loc:Location.none (module_type mty)
+      (Location.mknoloc (Untypeast.lident_of_path path))
 
 and core_type type_expr =
   let open Ast_helper in
   match Types.get_desc type_expr with
-  | Tvar { name = None; _ } | Tunivar { name = None; _ } -> Typ.any ()
-  | Tvar { name = Some s; _ } | Tunivar { name = Some s; _ } -> Typ.var s
+  | Tvar { name = None; jkind = _ } | Tunivar { name = None; jkind = _ } ->
+    (* CR modes: do something better here with the jkind *)
+    Typ.any None
+  | Tvar { name = Some s; jkind = _ } | Tunivar { name = Some s; jkind = _ } ->
+    (* CR modes: do something better here with the jkind *)
+    Typ.var s None
   | Tarrow
       ( (label, arg_alloc_mode, ret_alloc_mode),
         type_expr,
@@ -121,8 +123,10 @@ and core_type type_expr =
       List.map
         ~f:(fun v ->
           match get_desc v with
-          | Tunivar { name = Some name; _ } | Tvar { name = Some name; _ } ->
-            mknoloc name
+          | Tunivar { name = Some name; jkind = _ }
+          | Tvar { name = Some name; jkind = _ } ->
+            (* CR modes: do something  *)
+            (mknoloc name, None)
           | _ -> failwith "poly: not a var")
         type_exprs
     in
@@ -272,10 +276,11 @@ and signature_item (str_item : Types.signature_item) =
     in
     Sig.text [ Docstrings.docstring str Location.none ] |> List.hd
 
-and signature (items : Types.signature_item list) =
-  List.map (group_items items) ~f:(function
-    | Item item -> signature_item item
-    | Type (rec_flag, type_decls) -> Ast_helper.Sig.type_ rec_flag type_decls)
+and signature (items : Types.signature) =
+  Ast_helper.Sg.mk
+    (List.map (group_items items) ~f:(function
+      | Item item -> signature_item item
+      | Type (rec_flag, type_decls) -> Ast_helper.Sig.type_ rec_flag type_decls))
 
 and group_items (items : Types.signature_item list) =
   let rec read_type type_acc items =

src/analysis/stack_or_heap_enclosing.ml

@@ -105,7 +105,7 @@ let from_nodes ~lsp_compat ~pos ~path =
         | None, Record_unboxed -> ret_no_alloc "unboxed record"
         | None, (Record_boxed _ | Record_float | Record_ufloat | Record_mixed _)
           -> ret Unexpected_no_alloc)
-      | Texp_field (_, _, _, boxed_or_unboxed) -> (
+      | Texp_field (_, _, _, boxed_or_unboxed, _) -> (
         match boxed_or_unboxed with
         | Boxing (alloc_mode, _) -> ret_alloc alloc_mode.mode
         | Non_boxing _ -> None)

src/frontend/query_commands.ml

@@ -609,10 +609,9 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
     let ppxed_parsetree = Mpipeline.ppx_parsetree pipeline in
     let ppx_kind_with_attr = Ppx_expand.check_extension ~parsetree ~pos in
     match ppx_kind_with_attr with
-    | Some _ ->
+    | Some ppx_kind_with_attr ->
       `Found
-        (Ppx_expand.get_ppxed_source ~ppxed_parsetree ~pos
-           (Option.get ppx_kind_with_attr))
+        (Ppx_expand.get_ppxed_source ~ppxed_parsetree ~pos ppx_kind_with_attr)
     | None -> `No_ppx)
   | Locate (patho, ml_or_mli, pos, context) ->
     let typer = Mpipeline.typer_result pipeline in

src/kernel/extension.ml

@@ -142,6 +142,32 @@ let add_hidden_signature env sign =
   List.fold_left ~f:add_item ~init:env sign
 *)
 
+(* Combine a list of signatures together into one by turning [s1; s2; ...] into:
+     sig
+       include s1
+       include s2
+       ...
+     end *)
+let combine_sigs sigs : Parsetree.signature =
+  let items =
+    List.map sigs ~f:(fun sig_ : Parsetree.signature_item ->
+        { psig_desc =
+            Psig_include
+              ( { pincl_kind = Structure;
+                  pincl_mod =
+                    { pmty_desc = Pmty_signature sig_;
+                      pmty_loc = Location.none;
+                      pmty_attributes = []
+                    };
+                  pincl_loc = Location.none;
+                  pincl_attributes = []
+                },
+                [] );
+          psig_loc = Location.none
+        })
+  in
+  Ast_helper.Sg.mk items
+
 let register exts env =
   (* Log errors ? *)
   let try_type sg' = try type_sig env sg' with _exn -> [] in
@@ -155,8 +181,8 @@ let register exts env =
       exts
   in
   let process_ext e =
-    let prv = List.concat_map ~f:parse_sig e.private_def in
-    let pub = List.concat_map ~f:parse_sig e.public_def in
+    let prv = List.map ~f:parse_sig e.private_def |> combine_sigs in
+    let pub = List.map ~f:parse_sig e.public_def |> combine_sigs in
     (try_type prv, try_type pub)
   in
   let fakes, tops = List.split (List.map ~f:process_ext exts) in