Merge branch 'merge-flambda-backend-post-501' into update-merlin-501

src/ocaml/parsing/attr_helper.ml

@@ -23,7 +23,11 @@ type error =
 exception Error of Location.t * error
 
 let get_no_payload_attribute alt_names attrs =
-  match Builtin_attributes.filter_attributes [alt_names,true] attrs with
+  match
+    Builtin_attributes.filter_attributes
+      (Builtin_attributes.Attributes_filter.create [alt_names,true])
+      attrs
+  with
   | [] -> None
   | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name
   | [ {attr_name = name; _} ] ->

src/ocaml/parsing/builtin_attributes.ml

@@ -426,7 +426,13 @@ let has_attribute nms attrs =
        else false)
     attrs
 
-let filter_attributes nms_and_conds attrs =
+module Attributes_filter = struct
+  type t = (string list * bool) list
+
+  let create (t : t) = t
+end
+
+let filter_attributes (nms_and_conds : Attributes_filter.t) attrs =
   List.filter (fun a ->
     List.exists (fun (nms, cond) ->
       if List.mem a.attr_name.txt nms
@@ -623,39 +629,63 @@ let has_local_opt attrs =
 let has_curry attrs =
   has_attribute ["extension.curry"; "ocaml.curry"; "curry"] attrs
 
-(* extension.* is generated by the parser and not usually written directly,
-   so does not have a short form. An error is reported if it is seen when
-   the extension is disabled *)
-
-let check_local ext_names other_names attr =
-  if has_attribute ext_names attr then
-    if not (Language_extension.is_enabled Local) then
-      Error ()
-    else
-      Ok true
-  else
-    Ok (has_attribute other_names attr)
-
-let has_local attr =
-  check_local ["extension.local"] ["ocaml.local"; "local"] attr
-
-let has_global attrs =
-  check_local ["extension.global"] ["ocaml.global"; "global"] attrs
-
-let check_unique ext_names other_names attr =
-  if has_attribute ext_names attr then
-    if not (Language_extension.is_enabled Unique) then
-      Error ()
+(* Mode annotation attributes are handled fairly uniformly, so we have
+   a dedicated submodule for them.
+*)
+module Mode_annotation_attribute = struct
+
+  (* When you add a constructor here, be sure to add it to [all]. *)
+  type t =
+    | Local
+    | Global
+    | Unique
+    | Once
+
+  let all = [ Local; Global; Unique; Once; ]
+
+  (* extension.* is generated by the parser and not usually written directly,
+     so does not have a short form. An error is reported if it is seen when
+     the extension is disabled *)
+  let name = function
+    | Local -> "extension.local"
+    | Global -> "extension.global"
+    | Unique -> "extension.unique"
+    | Once -> "extension.once"
+
+  let extra_user_written_names = function
+    | Local -> [ "ocaml.local"; "local" ]
+    | Global -> [ "ocaml.global"; "global" ]
+    | Unique -> [ "ocaml.unique"; "unique" ]
+    | Once -> [ "ocaml.once"; "once" ]
+
+  let is_language_extension_enabled = function
+    | Local | Global -> Language_extension.is_enabled Local
+    | Unique | Once -> Language_extension.is_enabled Unique
+
+  let check t attr =
+    if has_attribute [ name t ] attr then
+      if not (is_language_extension_enabled t) then
+        Error ()
+      else
+        Ok true
     else
-      Ok true
-  else
-    Ok (has_attribute other_names attr)
-
-let has_unique attrs =
-  check_unique ["extension.unique"] ["ocaml.unique"; "unique"] attrs
-
-let has_once attr =
-  check_unique ["extension.once"] ["ocaml.once"; "once"] attr
+      Ok (has_attribute (extra_user_written_names t) attr)
+end
+
+let has_local attr = Mode_annotation_attribute.check Local attr
+let has_global attr = Mode_annotation_attribute.check Global attr
+let has_unique attr = Mode_annotation_attribute.check Unique attr
+let has_once attr = Mode_annotation_attribute.check Once attr
+
+let mode_annotation_attributes_filter =
+  List.map
+    (fun attr ->
+      let names =
+        Mode_annotation_attribute.name attr
+        :: Mode_annotation_attribute.extra_user_written_names attr
+      in
+      names, true)
+    Mode_annotation_attribute.all
 
 let tailcall attr =
   let has_nontail = has_attribute ["ocaml.nontail"; "nontail"] attr in

src/ocaml/parsing/builtin_attributes.mli

@@ -137,8 +137,15 @@ val warning_scope:
     misplaced attribute warnings. *)
 val has_attribute : string list -> Parsetree.attributes -> bool
 
-(** [filter_attributes nms_and_conds attrs] finds those attrs which
-    appear in one of the sublists of nms_and_conds with cond=true.
+module Attributes_filter : sig
+  type t
+
+  val create : (string list * bool) list -> t
+end
+
+(** [filter_attributes (Attributes_filter.create nms_and_conds) attrs] finds
+    those attrs which appear in one of the sublists of nms_and_conds with
+    cond=true.
 
     Each element [(nms, conds)] of the [nms_and_conds] list is a list of
     attribute names along with a boolean indicating whether to include
@@ -147,9 +154,10 @@ val has_attribute : string list -> Parsetree.attributes -> bool
     "unrolled" only in the case where flambda or flambda2 is configured).  We
     handle this by taking a bool, rather than simply passing fewer nms in those
     cases, to support misplaced attribute warnings - the attribute should not
-    count as misplaced if the compiler could use it in some configuration. *)
+    count as misplaced if the compiler could use it in some configuration.
+*)
 val filter_attributes :
-  (string list * bool) list -> Parsetree.attributes -> Parsetree.attributes
+  Attributes_filter.t -> Parsetree.attributes -> Parsetree.attributes
 
 val warn_on_literal_pattern: Parsetree.attributes -> bool
 val explicit_arity: Parsetree.attributes -> bool
@@ -174,6 +182,15 @@ val has_unique: Parsetree.attributes -> (bool,unit) result
 
 val has_once : Parsetree.attributes -> (bool, unit) result
 
+(** This filter selects attributes corresponding to mode annotations on
+    let-bindings.
+
+    This filter is used principally by the type-checker when it copies [local_],
+    [unique_], and [once_] mode annotation attributes from let-bindings to both
+    the let-bound expression and its pattern.
+*)
+val mode_annotation_attributes_filter : Attributes_filter.t
+
 (* CR layouts v1.5: Remove everything except for [Immediate64] and [Immediate]
    after rerouting [@@immediate]. *)
 type jkind_attribute =

src/ocaml/parsing/pprintast.ml

@@ -1540,28 +1540,6 @@ and bindings ctxt f (rf,l) =
         (binding "let" rf) x
         (list ~sep:"@," (binding "and" Nonrecursive)) xs
 
-let binding kwd rf f x =
-  let attrs, is_local = check_local_attr x.pvb_attributes in
-  let x =
-    match is_local, x.pvb_expr.pexp_desc with
-    | true, Pexp_apply
-        ({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) },
-         [Nolabel, sbody]) ->
-        {x with pvb_expr = sbody}
-    | _ -> x
-  in
-  pp f "@[<2>%s %a%s%a@]%a" kwd rec_flag rf
-    (if is_local then "local_ " else "")
-    (binding ctxt) x (item_attributes ctxt) attrs
-in
-match l with
-| [] -> ()
-| [x] -> binding "let" rf f x
-| x::xs ->
-    pp f "@[<v>%a@,%a@]"
-      (binding "let" rf) x
-      (list ~sep:"@," (binding "and" Nonrecursive)) xs
-
 and binding_op ctxt f x =
   match x.pbop_pat, x.pbop_exp with
   | {ppat_desc = Ppat_var { txt=pvar; _ }; ppat_attributes = []; _},

src/ocaml/typing/datarepr.ml

@@ -108,7 +108,7 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep =
          let all_void = all_void jkinds in
          if all_void then incr num_consts else incr num_nonconsts;
          all_void)
-      cstr_arg_jkindsNick Roberts
+      cstr_arg_jkinds
   in
   let describe_constructor (src_index, const_tag, nonconst_tag, acc)
         {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_uid} =

src/ocaml/typing/typecore.ml

@@ -8019,7 +8019,7 @@ and type_let_def_wrap_warnings
   let is_fake_let =
     match spat_sexp_list with
     | [{pvb_expr={pexp_desc=Pexp_match(
-           {pexp_desc=Pexp_ident({ txt = Longident.Lident name})},_)}}] ->
+           {pexp_desc=Pexp_ident({ txt = Longident.Lident name})},_)}}]
       when String.starts_with ~prefix:"*opt" name ->
         true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
     | _ ->

src/ocaml/typing/typedecl.ml

@@ -1362,7 +1362,7 @@ let update_decls_jkind env decls =
    - 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;*)
@@ -1378,8 +1378,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) =
@@ -1424,7 +1424,7 @@ 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 =
     (* The jkinds here shouldn't matter for the purposes of
@@ -1433,7 +1433,7 @@ let check_well_founded_manifest env loc path decl =
       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),
@@ -1451,7 +1451,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. *)
@@ -1470,7 +1470,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
@@ -1721,16 +1721,6 @@ let transl_type_decl env rec_flag sdecl_list =
     List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc))
       ids_list sdecl_list
   in
-  List.iter (fun (id, decl) ->
-    check_well_founded_manifest 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)
-      decl to_check)
-    decls;
   (* [check_abbrev_regularity] 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
@@ -1739,6 +1729,17 @@ let transl_type_decl env rec_flag sdecl_list =
     List.fold_left2
       (enter_type ~abstract_abbrevs:Abstract_rec_check_regularity rec_flag)
       env sdecl_list ids_list in
+  List.iter (fun (id, decl) ->
+    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 ~abs_env new_env (List.assoc id id_loc_list)
+      (Path.Pident id)
+      decl to_check)
+    decls;
   List.iter
     (check_abbrev_regularity ~abs_env new_env id_loc_list to_check) tdecls;
   (* Now that we've ruled out ill-formed types, we can perform the delayed
@@ -2550,7 +2551,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 ~abs_env:env env loc path decl to_check;
   (* additional coherence check, as one might build an incoherent signature,
      and use it to build an incoherent module, cf. #7851 *)