Updates for 5.2.0minus-9 (#137)

* Import ocaml sources for oxcaml/oxcaml@c3c58afb390

* Commit conflicts

* Resolve conflicts

* Fix type errors

* Bump version numbers

* Update ignored flags

* Promote tests

* Format

Author: goldfirere

src/analysis/destruct.ml

@@ -773,7 +773,9 @@ let refine_and_generate_branches patt config source patterns sub_patterns =
     (top_patt.Typedtree.pat_loc, str)
 
 let refine_complete_match (type a) parents (patt : a Typedtree.general_pattern)
-    config source patterns =
+    config source
+    (patterns :
+      Typedtree.value Typedtree.pattern_desc Typedtree.pattern_data list) =
   match Typedtree.classify_pattern patt with
   | Computation -> raise (Not_allowed "computation pattern")
   | Value ->

src/analysis/env_lookup.ml

@@ -141,7 +141,9 @@ let by_longident (nss : Namespace.inferred list) ident env =
                 Namespace.packed_label_description =
               (* Try looking up in boxed namespace, and then fallback to unboxed if that
                  fails *)
-              try P (Env.find_label_by_name Legacy ident env)
+              try
+                (P (Env.find_label_by_name Legacy ident env)
+                  : Namespace.packed_label_description)
               with Not_found ->
                 P (Env.find_label_by_name Unboxed_product ident env)
             in

src/kernel/mconfig.ml

@@ -435,30 +435,21 @@ let ocaml_ignored_flags =
     "-compat-32";
     "-config";
     "-custom";
-    "-dalloc";
     "-dclambda";
     "-dcmm";
-    "-dcombine";
     "-dcse";
     "-dflambda";
     "-dflambda-no-invariants";
     "-dflambda-verbose";
     "-dinstr";
-    "-dinterf";
     "-dlambda";
     "-dlinear";
-    "-dlive";
     "-dparsetree";
-    "-dprefer";
     "-dshape";
     "-drawclambda";
     "-drawflambda";
     "-drawlambda";
-    "-dreload";
-    "-dsel";
     "-dsource";
-    "-dspill";
-    "-dsplit";
     "-dstartup";
     "-dtimings";
     "-dprofile";
@@ -535,6 +526,7 @@ let ocaml_ignored_flags =
     "-flambda2-speculative-inlining-only-if-arguments-useful";
     "-flambda2-unbox-along-intra-function-control-flow";
     "-flambda2-unicode";
+    "-flambda2-kind-checks";
     "-no-flambda2-backend-cse-at-toplevel";
     "-no-flambda2-debug";
     "-no-flambda2-debug-concrete-types-only-on-canonicals";
@@ -569,8 +561,6 @@ let ocaml_ignored_flags =
     "-ddebug-invariants";
     "-cfg-peephole-optimize";
     "-no-cfg-peephole-optimize";
-    "-cfg-cse-optimize";
-    "-no-cfg-cse-optimize";
     "-verbose-types";
     "-no-verbose-types";
     "-fsse3";
@@ -609,15 +599,11 @@ let ocaml_ignored_flags =
     "-gno-upstream-dwarf";
     "-dzero-alloc";
     "-dletreclambda";
-    "-cfg-zero-alloc-checker";
-    "-no-cfg-zero-alloc-checker";
     "-dcounters";
     "-vectorize";
     "-no-vectorize";
     "-dvectorize";
     "-dump-into-csv";
-    "-cfg-selection";
-    "-no-cfg-selection";
     "-no-mach-ir";
     "-flambda2-reaper";
     "-no-flambda2-reaper";

src/ocaml/parsing/ast_helper.mli

@@ -126,7 +126,7 @@ module Pat:
                        -> (string option * pattern) list -> closed_flag
                        -> pattern
     val construct: ?loc:loc -> ?attrs:attrs ->
-      lid -> (str list * pattern) option -> pattern
+      lid -> ((str * jkind_annotation option) list * pattern) option -> pattern
     val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern
     val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag
                 -> pattern

src/ocaml/parsing/ast_iterator.ml

@@ -569,8 +569,12 @@ module P = struct
         iter_loc sub l;
         iter_opt
           (fun (vl,p) ->
-            List.iter (iter_loc sub) vl;
-            sub.pat sub p)
+             List.iter
+               (fun (v,j) ->
+                  iter_loc sub v;
+                  iter_opt (sub.jkind_annotation sub) j)
+               vl;
+             sub.pat sub p)
           p
     | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
     | Ppat_record (lpl, _cf)

src/ocaml/parsing/ast_mapper.ml

@@ -649,7 +649,12 @@ module P = struct
     | Ppat_construct (l, p) ->
         construct ~loc ~attrs (map_loc sub l)
           (map_opt
-             (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p)
+             (fun (vl, p) ->
+                List.map
+                  (fun (v, jk) ->
+                     map_loc sub v, Option.map (sub.jkind_annotation sub) jk)
+                  vl,
+                sub.pat sub p)
              p)
     | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
     | Ppat_record (lpl, cf) ->

src/ocaml/parsing/parsetree.mli

@@ -290,13 +290,17 @@ and pattern_desc =
           - If Closed, [n >= 2]
           - If Open, [n >= 1]
         *)
-  | Ppat_construct of Longident.t loc * (string loc list * pattern) option
+  | Ppat_construct of
+      Longident.t loc
+      * ((string loc * jkind_annotation option) list * pattern) option
       (** [Ppat_construct(C, args)] represents:
             - [C]               when [args] is [None],
             - [C P]             when [args] is [Some ([], P)]
             - [C (P1, ..., Pn)] when [args] is
                                            [Some ([], Ppat_tuple [P1; ...; Pn])]
-            - [C (type a b) P]  when [args] is [Some ([a; b], P)]
+            - [C (type a b) P]  when [args] is [Some ([a, None; b, None], P)]
+            - [C (type (a : k) b) P]
+                                when [args] is [Some ([a, Some k; b, None], P)]
          *)
   | Ppat_variant of label * pattern option
       (** [Ppat_variant(`A, pat)] represents:

src/ocaml/parsing/pprintast.ml

@@ -105,8 +105,6 @@ let ident_of_name ppf txt =
     else "(%s)"
   in fprintf ppf format txt
 
-let ident_of_name_loc ppf s = ident_of_name ppf s.txt
-
 let protect_longident ppf print_longident longprefix txt =
     if not (needs_parens txt) then
       fprintf ppf "%a.%a" print_longident longprefix ident_of_name txt
@@ -432,11 +430,11 @@ let include_kind f = function
   | Structure -> ()
 
 (* c ['a,'b] *)
-let rec class_params_def ctxt f =  function
+let rec class_params_def f =  function
   | [] -> ()
   | l ->
       pp f "[%a] " (* space *)
-        (list (type_param ctxt) ~sep:",") l
+        (list type_param ~sep:",") l
 
 and type_with_label ctxt f (label, c, mode) =
   match label with
@@ -499,6 +497,8 @@ and name_jkind f (name, jkind) =
         ident_of_name name
         (jkind_annotation reset_ctxt) jkind
 
+and name_loc_jkind f (str, jkind) = name_jkind f (str.txt,jkind)
+
 and core_type ctxt f x =
   let filtered_attrs = filter_curry_attrs x.ptyp_attributes in
   if filtered_attrs <> [] then begin
@@ -686,7 +686,7 @@ and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
                pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
            | Some (vl, x) ->
                pp f "%a@ (type %a)@;%a" longident_loc li
-                 (list ~sep:"@ " ident_of_name_loc) vl
+                 (list ~sep:"@ " name_loc_jkind) vl
                  (simple_pattern ctxt) x
            | None -> pp f "%a" longident_loc li)
     | _ -> simple_pattern ctxt f x
@@ -1290,7 +1290,7 @@ and class_type_declaration_list ctxt f l =
     let { pci_params=ls; pci_name={ txt; _ }; _ } = x in
     pp f "@[<2>%s %a%a%a@ =@ %a@]%a" kwd
       virtual_flag x.pci_virt
-      (class_params_def ctxt) ls
+      class_params_def ls
       ident_of_name txt
       (class_type ctxt) x.pci_expr
       (item_attributes ctxt) x.pci_attributes
@@ -1465,15 +1465,15 @@ and module_type ctxt f x =
 and with_constraint ctxt f = function
   | Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
       pp f "type@ %a %a =@ %a"
-        (type_params ctxt) ls
+        type_params ls
         longident_loc li (type_declaration ctxt) td
   | Pwith_module (li, li2) ->
       pp f "module %a =@ %a" longident_loc li longident_loc li2;
   | Pwith_modtype (li, mty) ->
       pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty;
   | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) ->
       pp f "type@ %a %a :=@ %a"
-        (type_params ctxt) ls
+        type_params ls
         longident_loc li
         (type_declaration ctxt) td
   | Pwith_modsubst (li, li2) ->
@@ -1528,7 +1528,7 @@ and signature_item ctxt f x : unit =
       let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
         pp f "@[<2>%s %a%a%a@;:@;%a@]%a" kwd
           virtual_flag x.pci_virt
-          (class_params_def ctxt) ls
+          class_params_def ls
           ident_of_name txt
           (class_type ctxt) x.pci_expr
           (item_attributes ctxt) x.pci_attributes
@@ -1893,7 +1893,7 @@ and structure_item ctxt f x =
         let args, constr, cl = extract_class_args x.pci_expr in
         pp f "@[<2>%s %a%a%a %a%a=@;%a@]%a" kwd
           virtual_flag x.pci_virt
-          (class_params_def ctxt) ls
+          class_params_def ls
           ident_of_name txt
           (list (label_exp ctxt) ~last:"@ ") args
           (option class_constraint) constr
@@ -1968,12 +1968,26 @@ and structure_item ctxt f x =
   | Pstr_kind_abbrev (name, jkind) ->
       kind_abbrev ctxt f name jkind
 
-and type_param ctxt f (ct, (a,b)) =
-  pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct
+(* Don't just use [core_type] because we do not want parens around params
+   with jkind annotations *)
+and core_type_param f ct = match ct.ptyp_desc with
+  | Ptyp_any None -> pp f "_"
+  | Ptyp_any (Some jk) -> pp f "_ : %a" (jkind_annotation reset_ctxt) jk
+  | Ptyp_var (s, None) -> tyvar f s
+  | Ptyp_var (s, Some jk) ->
+    pp f "%a : %a" tyvar s (jkind_annotation reset_ctxt) jk
+  | _ -> Misc.fatal_error "unexpected type in core_type_param"
 
-and type_params ctxt f = function
+and type_param f (ct, (a,b)) =
+  pp f "%s%s%a" (type_variance a) (type_injectivity b) core_type_param ct
+
+and type_params f = function
   | [] -> ()
-  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l
+  (* Normally, one param doesn't get parentheses, but it does when there is
+     a jkind annotation. *)
+  | [{ ptyp_desc = Ptyp_any (Some _) | Ptyp_var (_, Some _) }, _ as param] ->
+    pp f "(%a) " type_param param
+  | l -> pp f "%a " (list type_param ~first:"(" ~last:")" ~sep:",@;") l
 
 and type_def_list ctxt f (rf, exported, l) =
   let type_decl kwd rf f x =
@@ -1991,7 +2005,7 @@ and type_def_list ctxt f (rf, exported, l) =
     in
     pp f "@[<2>%s %a%a%a%t%s%a@]%a" kwd
       nonrec_flag rf
-      (type_params ctxt) x.ptype_params
+      type_params x.ptype_params
       ident_of_name x.ptype_name.txt
       layout_annot eq
       (type_declaration ctxt) x
@@ -2074,11 +2088,7 @@ and type_extension ctxt f x =
     pp f "@\n|@;%a" (extension_constructor ctxt) x
   in
   pp f "@[<2>type %a%a += %a@ %a@]%a"
-    (fun f -> function
-       | [] -> ()
-       | l ->
-           pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
-    x.ptyext_params
+    type_params x.ptyext_params
     longident_loc x.ptyext_path
     private_flag x.ptyext_private (* Cf: #7200 *)
     (list ~sep:"" extension_constructor)

src/ocaml/parsing/printast.ml

@@ -258,7 +258,11 @@ and pattern i ppf x =
       line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
       option i
         (fun i ppf (vl, p) ->
-          list i string_loc ppf vl;
+          list i
+            (fun i ppf (v, jk) ->
+               string_loc i ppf v;
+               jkind_annotation_opt i ppf jk)
+            ppf vl;
           pattern i ppf p)
         ppf po
   | Ppat_variant (l, po) ->