Merge 5.2.0minus-22

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 *)

src/ocaml/parsing/language_extension.ml

@@ -75,6 +75,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
   | Instances -> (module Unit)
   | Separability -> (module Unit)
   | Let_mutable -> (module Unit)
+  | Layout_poly -> (module Maturity)
 
 (* We'll do this in a more principled way later. *)
 (* CR layouts: Note that layouts is only "mostly" erasable, because of annoying
@@ -85,7 +86,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
    But we've decided to punt on this issue in the short term.
 *)
 let is_erasable : type a. a t -> bool = function
-  | Mode | Unique | Overwriting | Layouts -> true
+  | Mode | Unique | Overwriting | Layouts | Layout_poly -> true
   | Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays
   | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances
   | Separability | Let_mutable ->
@@ -114,6 +115,7 @@ module Exist_pair = struct
     | Pair (Instances, ()) -> Stable
     | Pair (Separability, ()) -> Stable
     | Pair (Let_mutable, ()) -> Stable
+    | Pair (Layout_poly, m) -> m
 
   let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext
 
@@ -124,6 +126,8 @@ module Exist_pair = struct
     | Pair (Small_numbers, m) ->
       to_string Small_numbers ^ "_" ^ maturity_to_string m
     | Pair (SIMD, m) -> to_string SIMD ^ "_" ^ maturity_to_string m
+    | Pair (Layout_poly, m) ->
+      to_string Layout_poly ^ "_" ^ maturity_to_string m
     | Pair
         ( (( Comprehensions | Include_functor | Polymorphic_parameters
            | Immutable_arrays | Module_strengthening | Labeled_tuples
@@ -161,6 +165,9 @@ module Exist_pair = struct
     | "instances" -> Some (Pair (Instances, ()))
     | "separability" -> Some (Pair (Separability, ()))
     | "let_mutable" -> Some (Pair (Let_mutable, ()))
+    | "layout_poly" -> Some (Pair (Layout_poly, Stable))
+    | "layout_poly_alpha" -> Some (Pair (Layout_poly, Alpha))
+    | "layout_poly_beta" -> Some (Pair (Layout_poly, Beta))
     | _ -> None
 end
 
@@ -183,7 +190,8 @@ let all_extensions =
     Pack Small_numbers;
     Pack Instances;
     Pack Separability;
-    Pack Let_mutable ]
+    Pack Let_mutable;
+    Pack Layout_poly ]
 
 (**********************************)
 (* string conversions *)
@@ -224,10 +232,11 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc_stdlib.eq option =
   | Instances, Instances -> Some Refl
   | Separability, Separability -> Some Refl
   | Let_mutable, Let_mutable -> Some Refl
+  | Layout_poly, Layout_poly -> Some Refl
   | ( ( Comprehensions | Mode | Unique | Overwriting | Include_functor
       | Polymorphic_parameters | Immutable_arrays | Module_strengthening
       | Layouts | SIMD | Labeled_tuples | Small_numbers | Instances
-      | Separability | Let_mutable ),
+      | Separability | Let_mutable | Layout_poly ),
       _ ) ->
     None
 

src/ocaml/parsing/language_extension.mli

@@ -33,6 +33,7 @@ type 'a t = 'a Language_extension_kernel.t =
   | Instances : unit t
   | Separability : unit t
   | Let_mutable : unit t
+  | Layout_poly : maturity t
 
 (** Require that an extension is enabled for at least the provided level, or
     else throw an exception at the provided location saying otherwise. *)

src/ocaml/parsing/parsetree.mli

@@ -204,6 +204,8 @@ and core_type_desc =
          *)
   | Ptyp_package of package_type  (** [(module S)]. *)
   | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *)
+  | Ptyp_quote of core_type (** [<[T]>] *)
+  | Ptyp_splice of core_type (** [$T] *)
   | Ptyp_of_kind of jkind_annotation (** [(type : k)] *)
   | Ptyp_extension of extension  (** [[%id]]. *)
 
@@ -527,6 +529,8 @@ and expression_desc =
           - [CLAUSES] is a series of [comprehension_clause].
     *)
   | Pexp_overwrite of expression * expression (** overwrite_ exp with exp *)
+  | Pexp_quote of expression (** runtime metaprogramming quotations <[E]> *)
+  | Pexp_splice of expression (** runtime metaprogramming splicing $(E) *)
   | Pexp_hole (** _ *)
 
 and case =
@@ -1334,15 +1338,15 @@ and module_binding =
 (** Values of type [module_binding] represents [module X = ME] *)
 
 and jkind_annotation_desc =
-  | Default
-  | Abbreviation of string
+  | Pjk_default
+  | Pjk_abbreviation of string
   (* CR layouts v2.8: [mod] can have only layouts on the left, not
      full kind annotations. We may want to narrow this type some.
      Internal ticket 5085. *)
-  | Mod of jkind_annotation * modes
-  | With of jkind_annotation * core_type * modalities
-  | Kind_of of core_type
-  | Product of jkind_annotation list
+  | Pjk_mod of jkind_annotation * modes
+  | Pjk_with of jkind_annotation * core_type * modalities
+  | Pjk_kind_of of core_type
+  | Pjk_product of jkind_annotation list
 
 and jkind_annotation =
   { pjkind_loc : Location.t

src/ocaml/parsing/pprintast.ml

@@ -452,9 +452,9 @@ and type_with_label ctxt f (label, c, mode) =
       (core_type_with_optional_legacy_modes core_type1 ctxt) (c, mode)
 
 and jkind_annotation ?(nested = false) ctxt f k = match k.pjkind_desc with
-  | Default -> pp f "_"
-  | Abbreviation s -> pp f "%s" s
-  | Mod (t, modes) ->
+  | Pjk_default -> pp f "_"
+  | Pjk_abbreviation s -> pp f "%s" s
+  | Pjk_mod (t, modes) ->
     begin match modes with
     | [] -> Misc.fatal_error "malformed jkind annotation"
     | _ :: _ ->
@@ -464,15 +464,15 @@ and jkind_annotation ?(nested = false) ctxt f k = match k.pjkind_desc with
           (pp_print_list ~pp_sep:pp_print_space mode) modes
       ) f (t, modes)
     end
-  | With (t, ty, modalities) ->
+  | Pjk_with (t, ty, modalities) ->
     Misc_stdlib.pp_parens_if nested (fun f (t, ty, modalities) ->
       pp f "%a with %a%a"
         (jkind_annotation ~nested:true ctxt) t
         (core_type ctxt) ty
         optional_space_atat_modalities modalities;
     ) f (t, ty, modalities)
-  | Kind_of ty -> pp f "kind_of_ %a" (core_type ctxt) ty
-  | Product ts ->
+  | Pjk_kind_of ty -> pp f "kind_of_ %a" (core_type ctxt) ty
+  | Pjk_product ts ->
     Misc_stdlib.pp_parens_if nested (fun f ts ->
       pp f "@[%a@]" (list (jkind_annotation ~nested:true ctxt) ~sep:"@ & ") ts
     ) f ts
@@ -611,6 +611,10 @@ and core_type1 ctxt f x =
                (list aux  ~sep:"@ and@ ")  cstrs)
     | Ptyp_open(li, ct) ->
        pp f "@[<hov2>%a.(%a)@]" longident_loc li (core_type ctxt) ct
+    | Ptyp_quote t ->
+        pp f "@[<hov2><[%a]>@]" (core_type ctxt) t
+    | Ptyp_splice t ->
+        pp f "@[<hov2>$(%a)@]" (core_type ctxt) t
     | Ptyp_extension e -> extension ctxt f e
     | (Ptyp_arrow _ | Ptyp_alias _ | Ptyp_poly _ | Ptyp_of_kind _) ->
        paren true (core_type ctxt) f x
@@ -1127,6 +1131,10 @@ and expression ctxt f x =
         pp f "@[<hov2>overwrite_@ %a@ with@ %a@]"
           (expression2 reset_ctxt) e1
           (expression2 reset_ctxt) e2
+    | Pexp_quote e ->
+        pp f "@[<hov2><[%a]>@]" (expression ctxt) e
+    | Pexp_splice e ->
+        pp f "@[$%a@]" (simple_expr ctxt) e
     | Pexp_hole -> pp f "_"
     | _ -> expression1 ctxt f x