restore #2540

Author: riaqn

chamelon/compat.jst.ml

@@ -4,6 +4,10 @@ open Mode
 
 let dummy_jkind = Jkind.Primitive.value ~why:(Unknown "dummy_layout")
 let dummy_value_mode = Value.disallow_right Value.legacy
+
+let dummy_alloc_mode =
+  { mode = Alloc.disallow_left Alloc.legacy; closure_context = None }
+
 let mkTvar name = Tvar { name; jkind = dummy_jkind }
 
 let mkTarrow (label, t1, t2, comm) =
@@ -29,21 +33,20 @@ let mkTexp_apply
   in
   Texp_apply (exp, args, pos, mode, za)
 
-type texp_tuple_identifier = string option list * Alloc.r
+type texp_tuple_identifier = string option list * alloc_mode
 
 let mkTexp_tuple ?id exps =
   let labels, alloc =
     match id with
-    | None -> (List.map (fun _ -> None) exps, Alloc.disallow_left Alloc.legacy)
+    | None -> (List.map (fun _ -> None) exps, dummy_alloc_mode)
     | Some id -> id
   in
   let exps = List.combine labels exps in
   Texp_tuple (exps, alloc)
 
-type texp_construct_identifier = Alloc.r option
+type texp_construct_identifier = alloc_mode option
 
-let mkTexp_construct ?id:(mode = Some (Alloc.disallow_left Alloc.legacy))
-    (name, desc, args) =
+let mkTexp_construct ?id:(mode = Some dummy_alloc_mode) (name, desc, args) =
   Texp_construct (name, desc, args, mode)
 
 type texp_function_param_identifier = {
@@ -86,7 +89,7 @@ type texp_function = {
 }
 
 type texp_function_identifier = {
-  alloc_mode : Alloc.r;
+  alloc_mode : alloc_mode;
   ret_sort : Jkind.sort;
   ret_mode : Alloc.l;
   zero_alloc : Zero_alloc.t;
@@ -112,7 +115,7 @@ let texp_function_param_identifier_defaults =
 
 let texp_function_defaults =
   {
-    alloc_mode = Alloc.disallow_left Alloc.legacy;
+    alloc_mode = dummy_alloc_mode;
     ret_sort = Jkind.Sort.value;
     ret_mode = Alloc.disallow_right Alloc.legacy;
     zero_alloc = Zero_alloc.default;

ocaml/boot/menhir/parser.mli

@@ -19,6 +19,7 @@ type token =
   | STRUCT
   | STRING of (string * Location.t * string option)
   | STAR
+  | STACK
   | SIG
   | SEMISEMI
   | SEMI

ocaml/lambda/translcore.ml

@@ -290,7 +290,7 @@ let fuse_method_arity (parent : fusable_function) : fusable_function =
         (function (Texp_poly _, _, _) -> true | _ -> false)
         exp_extra
     ->
-      begin match transl_alloc_mode_r method_.alloc_mode with
+      begin match transl_alloc_mode method_.alloc_mode with
       | Alloc_heap -> ()
       | Alloc_local ->
           (* If we support locally-allocated objects, we'll also have to
@@ -506,7 +506,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         Lconst(Const_block(0, List.map extract_constant ll))
       with Not_constant ->
         Lprim(Pmakeblock(0, Immutable, Some shape,
-                         transl_alloc_mode_r alloc_mode),
+                         transl_alloc_mode alloc_mode),
               ll,
               (of_location ~scopes e.exp_loc))
       end
@@ -552,7 +552,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
           begin match constant with
           | Some constant -> Lconst constant
           | None ->
-              let alloc_mode = transl_alloc_mode_r (Option.get alloc_mode) in
+              let alloc_mode = transl_alloc_mode (Option.get alloc_mode) in
               let makeblock =
                 match cstr.cstr_shape with
                 | Constructor_uniform_value ->
@@ -578,7 +578,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
                that out by checking that the sort list is empty *)
             lam)
           else
-            let alloc_mode = transl_alloc_mode_r (Option.get alloc_mode) in
+            let alloc_mode = transl_alloc_mode (Option.get alloc_mode) in
             let makeblock =
               match cstr.cstr_shape with
               | Constructor_uniform_value ->
@@ -613,13 +613,13 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
                                    extract_constant lam]))
           with Not_constant ->
             Lprim(Pmakeblock(0, Immutable, None,
-                             transl_alloc_mode_r alloc_mode),
+                             transl_alloc_mode alloc_mode),
                   [Lconst(const_int tag); lam],
                   of_location ~scopes e.exp_loc)
       end
   | Texp_record {fields; representation; extended_expression; alloc_mode} ->
       transl_record ~scopes e.exp_loc e.exp_env
-        (Option.map transl_alloc_mode_r alloc_mode)
+        (Option.map transl_alloc_mode alloc_mode)
         fields representation extended_expression
   | Texp_field(arg, id, lbl, float) ->
       let targ = transl_exp ~scopes Jkind.Sort.for_record arg in
@@ -640,7 +640,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
             | Boxing (alloc_mode, _) -> alloc_mode
             | Non_boxing _ -> assert false
           in
-          let mode = transl_alloc_mode_r alloc_mode in
+          let mode = transl_alloc_mode alloc_mode in
           Lprim (Pfloatfield (lbl.lbl_pos, sem, mode), [targ],
                  of_location ~scopes e.exp_loc)
         | Record_ufloat ->
@@ -667,7 +667,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
                 | Float_boxed ->
                   (match float with
                     | Boxing (mode, _) ->
-                        flat_read_float_boxed (transl_alloc_mode_r mode)
+                        flat_read_float_boxed (transl_alloc_mode mode)
                     | Non_boxing _ ->
                         Misc.fatal_error
                           "expected typechecking to make [float] boxing mode\
@@ -729,7 +729,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
                      transl_exp ~scopes lbl_sort newval],
             of_location ~scopes e.exp_loc)
   | Texp_array (amut, element_sort, expr_list, alloc_mode) ->
-      let mode = transl_alloc_mode_r alloc_mode in
+      let mode = transl_alloc_mode alloc_mode in
       let kind = array_kind e element_sort in
       let ll =
         transl_list ~scopes
@@ -1642,7 +1642,7 @@ and transl_function ~in_new_scope ~scopes e params body
       ~alloc_mode ~ret_mode:sreturn_mode ~ret_sort:sreturn_sort ~region:sregion
       ~zero_alloc =
   let attrs = e.exp_attributes in
-  let mode = transl_alloc_mode_r alloc_mode in
+  let mode = transl_alloc_mode alloc_mode in
   let zero_alloc = Zero_alloc.get zero_alloc in
   let assume_zero_alloc =
     match zero_alloc with
@@ -2091,7 +2091,7 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial =
     match arg, exn_cases with
     | {exp_desc = Texp_tuple (argl, alloc_mode)}, [] ->
       assert (static_handlers = []);
-      let mode = transl_alloc_mode_r alloc_mode in
+      let mode = transl_alloc_mode alloc_mode in
       let argl =
         List.map (fun (_, a) -> (a, Jkind.Sort.for_tuple_element)) argl
       in
@@ -2110,7 +2110,7 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial =
             argl
           |> List.split
         in
-        let mode = transl_alloc_mode_r alloc_mode in
+        let mode = transl_alloc_mode alloc_mode in
         static_catch (transl_list ~scopes argl) val_ids
           (Matching.for_multiple_match ~scopes ~return_layout e.exp_loc
              lvars mode val_cases partial)

ocaml/lambda/translmode.ml

@@ -35,6 +35,9 @@ let transl_alloc_mode_r mode =
   (* we only take the locality axis *)
   Alloc.proj (Comonadic Areality) mode |> transl_locality_mode_r
 
+let transl_alloc_mode (mode : Typedtree.alloc_mode) =
+  transl_alloc_mode_r mode.mode
+
 let transl_modify_mode locality =
   match Locality.zap_to_floor locality with
   | Global -> modify_heap

ocaml/lambda/translmode.mli

@@ -20,4 +20,6 @@ val transl_alloc_mode_l : (allowed * 'r) Alloc.t -> Lambda.alloc_mode
 
 val transl_alloc_mode_r : ('l * allowed) Alloc.t -> Lambda.alloc_mode
 
+val transl_alloc_mode : Typedtree.alloc_mode -> Lambda.alloc_mode
+
 val transl_modify_mode : (allowed * 'r) Locality.t -> Lambda.modify_mode

ocaml/parsing/ast_helper.ml

@@ -222,6 +222,7 @@ module Exp = struct
     mk ?loc ?attrs (Pexp_letop {let_; ands; body})
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
   let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable
+  let stack ?loc ?attrs e = mk ?loc ?attrs (Pexp_stack e)
 
   let case lhs ?guard rhs =
     {

ocaml/parsing/ast_helper.mli

@@ -191,6 +191,7 @@ module Exp:
                -> binding_op list -> expression -> expression
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
     val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression
+    val stack : ?loc:loc -> ?attrs:attrs -> expression -> expression
 
     val case: pattern -> ?guard:expression -> expression -> case
     val binding_op: str -> pattern -> expression -> loc -> binding_op

ocaml/parsing/ast_iterator.ml

@@ -632,6 +632,7 @@ module E = struct
         sub.expr sub body
     | Pexp_extension x -> sub.extension sub x
     | Pexp_unreachable -> ()
+    | Pexp_stack e -> sub.expr sub e
 
   let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
     iter_loc sub pbop_op;

ocaml/parsing/ast_mapper.ml

@@ -746,6 +746,7 @@ module E = struct
           (List.map (sub.binding_op sub) ands) (sub.expr sub body)
     | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
     | Pexp_unreachable -> unreachable ~loc ~attrs ()
+    | Pexp_stack e -> stack ~loc ~attrs (sub.expr sub e)
 
   let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
     let open Exp in

ocaml/parsing/depend.ml

@@ -330,6 +330,7 @@ let rec add_expr bv exp =
       | Ok { arg; _ } -> add_expr bv arg
       end
   | Pexp_extension e -> handle_extension e
+  | Pexp_stack e -> add_expr bv e
   | Pexp_unreachable -> ()
 
 and add_expr_jane_syntax bv : Jane_syntax.Expression.t -> _ = function

ocaml/parsing/lexer.mll

@@ -84,6 +84,7 @@ let keyword_table =
     "private", PRIVATE;
     "rec", REC;
     "sig", SIG;
+    "stack_", STACK;
     "struct", STRUCT;
     "then", THEN;
     "to", TO;

ocaml/parsing/parser.mly

@@ -1047,6 +1047,7 @@ let unboxed_type sloc lident tys =
 %token HASH_SUFFIX            "# "
 %token <string> HASHOP        "##" (* just an example *)
 %token SIG                    "sig"
+%token STACK                  "stack_"
 %token STAR                   "*"
 %token <string * Location.t * string option>
        STRING                 "\"hello\"" (* just an example *)
@@ -1138,7 +1139,7 @@ The precedences must be listed from low to high.
 %nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT HASH_FLOAT INT HASH_INT OBJECT
           LBRACE LBRACELESS LBRACKET LBRACKETBAR LBRACKETCOLON LIDENT LPAREN
           NEW PREFIXOP STRING TRUE UIDENT
-          LBRACKETPERCENT QUOTED_STRING_EXPR
+          LBRACKETPERCENT QUOTED_STRING_EXPR STACK
 
 
 /* Entry points */
@@ -2867,6 +2868,8 @@ fun_expr:
 %inline expr_:
   | simple_expr nonempty_llist(labeled_simple_expr)
       { mkexp ~loc:$sloc (Pexp_apply($1, $2)) }
+  | STACK simple_expr
+      { mkexp ~loc:$sloc (Pexp_stack $2) }
   | labeled_tuple %prec below_COMMA
       { pexp_ltuple $sloc $1 }
   | mkrhs(constr_longident) simple_expr %prec below_HASH

ocaml/parsing/parsetree.mli

@@ -436,6 +436,7 @@ and expression_desc =
             - [let* P0 = E00 and* P1 = E01 in E1] *)
   | Pexp_extension of extension  (** [[%id]] *)
   | Pexp_unreachable  (** [.] *)
+  | Pexp_stack of expression (** stack_ exp *)
 
 and case =
     {

ocaml/parsing/pprintast.ml

@@ -995,6 +995,9 @@ and expression ?(jane_syntax_parens = false) ctxt f x =
                 end (e,l)
         end
 
+    | Pexp_stack e ->
+        (* Similar to the common case of [Pexp_apply] *)
+        pp f "@[<hov2>stack_@ %a@]" (expression2 reset_ctxt)  e
     | Pexp_construct (li, Some eo)
       when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
         (match view_expr x with

ocaml/parsing/printast.ml

@@ -398,6 +398,9 @@ and expression i ppf x =
       payload i ppf arg
   | Pexp_unreachable ->
       line i ppf "Pexp_unreachable"
+  | Pexp_stack e ->
+      line i ppf "Pexp_stack\n";
+      expression i ppf e
 
 and jkind_annotation i ppf (jkind : jkind_annotation) =
   match jkind with

ocaml/testsuite/tests/language-extensions/pprintast_unconditional.ml

@@ -37,6 +37,11 @@ module Example = struct
      end"
 
   let local_exp = parse expression "let x = foo (local_ x) in local_ y"
+  let stack_exp = parse expression
+    "let x = stack_ 42 in \
+     let y = stack_ (f x) in \
+     let z = foo (stack_ 42) in \
+     foo (stack_ (f x))"
   let fun_with_modes_on_arg = parse expression
     "let f (a @ local) ~(b @ local) ?(c @ local) \
           ?(d @ local = 1) ~e:(e @ local) ?f:(f @ local = 2) \
@@ -186,6 +191,7 @@ end = struct
   let modality_val = test "modality_val" module_type Example.modality_val
 
   let local_exp = test "local_exp" expression Example.local_exp
+  let stack_exp = test "stack_exp" expression Example.stack_exp
   let fun_with_modes_on_arg = test "fun_with_modes_on_arg" expression Example.fun_with_modes_on_arg
 
   let longident = test "longident" longident Example.longident

ocaml/testsuite/tests/language-extensions/pprintast_unconditional.reference

@@ -30,6 +30,10 @@ fun_with_modes_on_arg:
     ?f:(local_ f= 2) () = () in
   f
 
+stack_exp:
+  let x = stack_ 42 in
+  let y = stack_ (f x) in let z = foo (stack_ 42) in foo (stack_ (f x))
+
 longident: No.Longidents.Require.extensions
 
 expression: [x for x = 1 to 10]
@@ -144,6 +148,10 @@ fun_with_modes_on_arg:
     ?f:(local_ f= 2) () = () in
   f
 
+stack_exp:
+  let x = stack_ 42 in
+  let y = stack_ (f x) in let z = foo (stack_ 42) in foo (stack_ (f x))
+
 longident: No.Longidents.Require.extensions
 
 expression: [x for x = 1 to 10]