Merge 5.2.0minus-22

import-ocaml-source.sh

@@ -3,7 +3,7 @@
 cd "$(dirname "${BASH_SOURCE[0]}")"
 
 # Script arguments with their default values
-repository=https://github.com/ocaml-flambda/flambda-backend
+repository=https://github.com/oxcaml/oxcaml
 subdirectory=.
 old_subdirectory=.
 
@@ -80,7 +80,7 @@ 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" "$old_subdirectory"
 
-# Then, fetch the new flambda-backend sources (which include ocaml-jst) and
+# Then, fetch the new oxcaml sources (which include ocaml-jst) and
 # copy into upstream/ocaml_flambda
 git fetch "$repository" "$commitish"
 rev=$(git rev-parse FETCH_HEAD)

src/analysis/construct.ml

@@ -558,6 +558,7 @@ module Gen = struct
           List.map choices ~f:(fun choice ->
               Ast_helper.Exp.unboxed_tuple choice)
         | Tvariant row_desc -> variant env rtyp row_desc
+        | Tquote _ | Tsplice _ -> []
         | Tpackage (path, lids_args) -> begin
           let open Ast_helper in
           try

src/analysis/ptyp_of_type.ml

@@ -134,6 +134,8 @@ and core_type type_expr =
     in
     Typ.poly names @@ core_type type_expr
   | Tof_kind _jkind -> (* CR modes: this is terrible *) Typ.any None
+  | Tquote type_expr -> Typ.quote (core_type type_expr)
+  | Tsplice type_expr -> Typ.splice (core_type type_expr)
   | Tpackage (path, lids_type_exprs) ->
     let loc = mknoloc (Untypeast.lident_of_path path) in
     let args =

src/analysis/syntax_doc.ml

@@ -259,6 +259,10 @@ let get_mode_doc mode =
       Some "Functions with this mode can read but not write mutable data"
     | Comonadic Statefulness, Stateless ->
       Some "Functions with this mode cannot access mutable data"
+    | Comonadic Forkable, Forkable ->
+      Some "Values with this mode can be forked to other threads"
+    | Comonadic Forkable, Unforkable ->
+      Some "Values with this mode cannot be forked to other threads"
   in
   let doc_url =
     let subpage =
@@ -271,6 +275,7 @@ let get_mode_doc mode =
       | Comonadic Yielding -> "modes/intro/"
       | Monadic Visibility -> "modes/intro/"
       | Comonadic Statefulness -> "modes/intro/"
+      | Comonadic Forkable -> "modes/intro/"
     in
     syntax_doc_url Oxcaml subpage
   in
@@ -641,16 +646,16 @@ let get_oxcaml_syntax_doc cursor_loc nodes : syntax_info =
       get_modality_doc modality
     | _ -> get_modality_doc modality)
   (* Jkinds *)
-  | Jkind_annotation { pjkind_desc = Abbreviation abbrev; _ } :: _ ->
+  | Jkind_annotation { pjkind_desc = Pjk_abbreviation abbrev; _ } :: _ ->
     get_jkind_abbrev_doc abbrev
-  | Jkind_annotation { pjkind_desc = Mod _; _ } :: _ ->
+  | Jkind_annotation { pjkind_desc = Pjk_mod _; _ } :: _ ->
     Some
       { name = "`mod` keyword (in a kind)";
         description = "Types of this kind will cross the following modes";
         documentation = syntax_doc_url Oxcaml "kinds/intro/";
         level = Advanced
       }
-  | Jkind_annotation { pjkind_desc = With (_, with_type, _); _ } :: _ -> (
+  | Jkind_annotation { pjkind_desc = Pjk_with (_, with_type, _); _ } :: _ -> (
     match compare_cursor_to_loc with_type.ptyp_loc with
     | Before ->
       Some

src/analysis/tail_analysis.ml

@@ -91,7 +91,10 @@ let expr_tail_positions = function
   | Texp_setmutvar _
   | Texp_idx _
   | Texp_atomic_loc _
-  | Texp_hole _ -> []
+  | Texp_hole _
+  | Texp_quotation _
+  | Texp_antiquotation _
+  | Texp_eval _ -> []
   | Texp_match (_, _, cs, _) -> List.map cs ~f:(fun c -> Case c)
   | Texp_try (_, cs) -> List.map cs ~f:(fun c -> Case c)
   | Texp_letmodule (_, _, _, _, e)

src/ocaml/merlin_specific/browse_raw.ml

@@ -504,6 +504,9 @@ let rec of_expression_desc loc = function
     of_block_access block_access ** list_fold of_unboxed_access unboxed_access
   | Texp_atomic_loc (exp, _, _, _, _) -> of_expression exp
   | Texp_hole _ -> id_fold
+  | Texp_quotation exp -> of_expression exp
+  | Texp_antiquotation exp -> of_expression exp
+  | Texp_eval (ct, _) -> of_core_type ct
 
 (* We should consider taking into account param.fp_loc at some point, as it
    allows us to respond with the *parameter*'s type (as opposed to the
@@ -645,6 +648,8 @@ and of_core_type_desc = function
     of_core_type ct ** of_jkind_annotation_opt jkind
   | Ttyp_variant (rfs, _, _) -> list_fold (fun rf -> app (Row_field rf)) rfs
   | Ttyp_package pt -> app (Package_type pt)
+  | Ttyp_quote ct -> of_core_type ct
+  | Ttyp_splice ct -> of_core_type ct
 
 and of_class_type_desc = function
   | Tcty_constr (_, _, cts) -> list_fold of_core_type cts
@@ -671,13 +676,13 @@ let of_jkind_annotation_desc : Parsetree.jkind_annotation_desc -> _ =
     id_fold
   in
   function
-  | Default | Abbreviation _ -> id_fold
-  | Mod (jkind, modes) -> of_jkind_annotation jkind ** list_fold of_mode modes
-  | With (jkind, ct, modalities) ->
+  | Pjk_default | Pjk_abbreviation _ -> id_fold
+  | Pjk_mod (jkind, modes) -> of_jkind_annotation jkind ** list_fold of_mode modes
+  | Pjk_with (jkind, ct, modalities) ->
     of_jkind_annotation jkind ** of_core_type ct
     ** list_fold of_modality modalities
-  | Kind_of ct -> of_core_type ct
-  | Product jkinds -> list_fold of_jkind_annotation jkinds
+  | Pjk_kind_of ct -> of_core_type ct
+  | Pjk_product jkinds -> list_fold of_jkind_annotation jkinds
 
 let of_attribute (attr : attribute) =
   let name = attr.attr_name.txt in

src/ocaml/parsing/ast_helper.ml

@@ -79,6 +79,8 @@ module Typ = struct
   let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
   let open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t))
+  let quote ?loc ?attrs t = mk ?loc ?attrs (Ptyp_quote t)
+  let splice ?loc ?attrs t = mk ?loc ?attrs (Ptyp_splice t)
   let of_kind ?loc ?attrs a = mk ?loc ?attrs (Ptyp_of_kind a)
 
   let force_poly t =
@@ -138,6 +140,10 @@ module Typ = struct
             Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
         | Ptyp_open (mod_ident, core_type) ->
             Ptyp_open (mod_ident, loop core_type)
+        | Ptyp_quote core_type ->
+            Ptyp_quote (loop core_type)
+        | Ptyp_splice core_type ->
+            Ptyp_splice (loop core_type)
         | Ptyp_of_kind jkind ->
             Ptyp_of_kind (loop_jkind jkind)
         | Ptyp_extension (s, arg) ->
@@ -147,12 +153,13 @@ module Typ = struct
     and loop_jkind jkind =
       let pjkind_desc =
         match jkind.pjkind_desc with
-        | Default as x -> x
-        | Abbreviation _ as x -> x
-        | Mod (jkind, modes) -> Mod (loop_jkind jkind, modes)
-        | With (jkind, typ, modalities) -> With (loop_jkind jkind, loop typ, modalities)
-        | Kind_of typ -> Kind_of (loop typ)
-        | Product jkinds -> Product (List.map loop_jkind jkinds)
+        | Pjk_default as x -> x
+        | Pjk_abbreviation _ as x -> x
+        | Pjk_mod (jkind, modes) -> Pjk_mod (loop_jkind jkind, modes)
+        | Pjk_with (jkind, typ, modalities) ->
+          Pjk_with (loop_jkind jkind, loop typ, modalities)
+        | Pjk_kind_of typ -> Pjk_kind_of (loop typ)
+        | Pjk_product jkinds -> Pjk_product (List.map loop_jkind jkinds)
       in
       { jkind with pjkind_desc }
     and loop_row_field field =
@@ -266,6 +273,8 @@ module Exp = struct
   let stack ?loc ?attrs e = mk ?loc ?attrs (Pexp_stack e)
   let comprehension ?loc ?attrs e = mk ?loc ?attrs (Pexp_comprehension e)
   let overwrite ?loc ?attrs a b = mk ?loc ?attrs (Pexp_overwrite (a, b))
+  let quote ?loc ?attrs a = mk ?loc ?attrs (Pexp_quote a)
+  let splice ?loc ?attrs a = mk ?loc ?attrs (Pexp_splice a)
   let hole ?loc ?attrs () = mk ?loc ?attrs Pexp_hole
 
   let case lhs ?guard rhs =

src/ocaml/parsing/ast_helper.mli

@@ -94,6 +94,8 @@ module Typ :
     val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
                  -> core_type
     val open_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type -> core_type
+    val quote : ?loc:loc -> ?attrs:attrs -> core_type -> core_type
+    val splice : ?loc:loc -> ?attrs:attrs -> core_type -> core_type
     val of_kind : ?loc:loc -> ?attrs:attrs -> jkind_annotation -> core_type
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
 
@@ -224,6 +226,8 @@ module Exp:
     val stack : ?loc:loc -> ?attrs:attrs -> expression -> expression
     val comprehension :
       ?loc:loc -> ?attrs:attrs -> comprehension_expression -> expression
+    val quote : ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val splice : ?loc:loc -> ?attrs:attrs -> expression -> expression
     val overwrite : ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression
     val hole : ?loc:loc -> ?attrs:attrs -> unit -> expression
 

src/ocaml/parsing/ast_iterator.ml

@@ -155,6 +155,8 @@ module T = struct
     | Ptyp_open (mod_ident, t) ->
         iter_loc sub mod_ident;
         sub.typ sub t
+    | Ptyp_quote t -> sub.typ sub t
+    | Ptyp_splice t -> sub.typ sub t
     | Ptyp_of_kind jkind ->
         sub.jkind_annotation sub jkind
     | Ptyp_extension x -> sub.extension sub x
@@ -552,6 +554,8 @@ module E = struct
     | Pexp_stack e -> sub.expr sub e
     | Pexp_comprehension e -> iter_comp_exp sub e
     | Pexp_overwrite (e1, e2) -> sub.expr sub e1; sub.expr sub e2
+    | Pexp_quote e -> sub.expr sub e
+    | Pexp_splice e -> sub.expr sub e
     | Pexp_hole -> ()
 
   let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
@@ -854,17 +858,17 @@ let default_iterator =
       (fun this { pjkind_loc; pjkind_desc } ->
          this.location this pjkind_loc;
          match pjkind_desc with
-         | Default -> ()
-         | Abbreviation (_ : string) -> ()
-         | Mod (t, mode_list) ->
+         | Pjk_default -> ()
+         | Pjk_abbreviation (_ : string) -> ()
+         | Pjk_mod (t, mode_list) ->
              this.jkind_annotation this t;
              this.modes this mode_list
-         | With (t, ty, modalities) ->
+         | Pjk_with (t, ty, modalities) ->
              this.jkind_annotation this t;
              this.typ this ty;
              this.modalities this modalities
-         | Kind_of ty -> this.typ this ty
-         | Product ts -> List.iter (this.jkind_annotation this) ts);
+         | Pjk_kind_of ty -> this.typ this ty
+         | Pjk_product ts -> List.iter (this.jkind_annotation this) ts);
 
     directive_argument =
       (fun this a ->

src/ocaml/parsing/ast_mapper.ml

@@ -193,6 +193,10 @@ module T = struct
           (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
     | Ptyp_open (mod_ident, t) ->
         open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t)
+    | Ptyp_quote t ->
+        quote ~loc ~attrs (sub.typ sub t)
+    | Ptyp_splice t ->
+        splice ~loc ~attrs (sub.typ sub t)
     | Ptyp_of_kind jkind ->
         of_kind ~loc ~attrs (sub.jkind_annotation sub jkind)
     | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
@@ -629,6 +633,8 @@ module E = struct
     | Pexp_stack e -> stack ~loc ~attrs (sub.expr sub e)
     | Pexp_comprehension c -> comprehension ~loc ~attrs (map_cexp sub c)
     | Pexp_overwrite (e1, e2) -> overwrite ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_quote e -> quote ~loc ~attrs e
+    | Pexp_splice e -> splice ~loc ~attrs e
     | Pexp_hole -> hole ~loc ~attrs ()
 
   let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
@@ -961,14 +967,19 @@ let default_mapper =
       let pjkind_loc = this.location this pjkind_loc in
       let pjkind_desc =
         match pjkind_desc with
-        | Default -> Default
-        | Abbreviation (s : string) -> Abbreviation s
-        | Mod (t, mode_list) ->
-          Mod (this.jkind_annotation this t, this.modes this mode_list)
-        | With (t, ty, modalities) ->
-          With (this.jkind_annotation this t, this.typ this ty, this.modalities this modalities)
-        | Kind_of ty -> Kind_of (this.typ this ty)
-        | Product ts -> Product (List.map (this.jkind_annotation this) ts)
+        | Pjk_default -> Pjk_default
+        | Pjk_abbreviation (s : string) -> Pjk_abbreviation s
+        | Pjk_mod (t, mode_list) ->
+          Pjk_mod (this.jkind_annotation this t, this.modes this mode_list)
+        | Pjk_with (t, ty, modalities) ->
+          Pjk_with (
+            this.jkind_annotation this t,
+            this.typ this ty,
+            this.modalities this modalities
+          )
+        | Pjk_kind_of ty -> Pjk_kind_of (this.typ this ty)
+        | Pjk_product ts ->
+          Pjk_product (List.map (this.jkind_annotation this) ts)
       in
       { pjkind_loc; pjkind_desc });
 

src/ocaml/parsing/builtin_attributes.ml

@@ -49,17 +49,23 @@ let unchecked_zero_alloc_attributes = Attribute_table.create 1
 let mark_zero_alloc_attribute_checked txt loc =
   Attribute_table.remove unchecked_zero_alloc_attributes { txt; loc }
 let register_zero_alloc_attribute attr =
-    Attribute_table.replace unchecked_zero_alloc_attributes attr ()
+    Attribute_table.replace unchecked_zero_alloc_attributes attr
+     (Warnings.backup ())
 let warn_unchecked_zero_alloc_attribute () =
     (* When using -i, attributes will not have been translated, so we can't
      warn about missing ones. *)
   if !Clflags.print_types then ()
   else
   let keys = List.of_seq (Attribute_table.to_seq_keys unchecked_zero_alloc_attributes) in
   let keys = List.sort attr_order keys in
+  (* Treatment of warnings is similar to [Typecore.force_delayed_checks]. *)
+  let w_old = Warnings.backup () in
   List.iter (fun sloc ->
+    let w = Attribute_table.find unchecked_zero_alloc_attributes sloc in
+    Warnings.restore w;
     Location.prerr_warning sloc.loc (Warnings.Unchecked_zero_alloc_attribute))
-    keys
+    keys;
+  Warnings.restore w_old
 
 let warn_unused () =
   let keys = List.of_seq (Attribute_table.to_seq_keys unused_attrs) in
@@ -122,6 +128,9 @@ let builtin_attrs =
   ; "or_null_reexport"
   ; "no_recursive_modalities"
   ; "jane.non_erasable.instances"
+  ; "cold"
+  ; "regalloc"
+  ; "regalloc_param"
   ]
 
 let builtin_attrs =
@@ -1139,6 +1148,11 @@ let get_tracing_probe_payload (payload : Parsetree.payload) =
   in
   Ok { name; name_loc; enabled_at_init; arg }
 
+let get_eval_payload payload =
+  match payload with
+  | PTyp typ -> Ok typ
+  | _ -> Error ()
+
 let has_atomic attrs = has_attribute "atomic" attrs
 
 (* Merlin specific *)

src/ocaml/parsing/builtin_attributes.mli

@@ -119,7 +119,6 @@ val mark_deprecated_mutable_used : Parsetree.attributes -> unit
     in late stages of compilation in the backend.
     Registering them helps detect code that is not checked,
     because it is optimized away by the middle-end.  *)
-val register_zero_alloc_attribute : string Location.loc -> unit
 val mark_zero_alloc_attribute_checked : string -> Location.t -> unit
 val warn_unchecked_zero_alloc_attribute : unit -> unit
 
@@ -346,6 +345,11 @@ type tracing_probe =
 val get_tracing_probe_payload :
   Parsetree.payload -> (tracing_probe, unit) result
 
+(** Gets the payload of a [eval] extension node which evaluates quotes,
+    for example: [%eval: int] *)
+val get_eval_payload :
+  Parsetree.payload -> (Parsetree.core_type, unit) result
+
 val has_atomic: Parsetree.attributes -> bool
 
 (* Merlin specific *)