Cherry pick overwriting (#3310)

* Basic overwriting syntax (#3089) * Basic overwriting syntax * Update line numbers in expect tests after cherry-pick * Implement suggestions * Update tests * Implement suggestions * Remove nested quotes * Revert "Remove nested quotes" This reverts commit 72eaa04. * Overwriting tests (#3123) * Tests for overwriting * Remove old tests for unique overwrites and fix typos * Add overwriting tests back * Add tests for lifting out constants * Update tests * Use extension universe alpha * Test all cases for gc soundness bug * Review feedback: add more CRs and clarify overwriting_map.ml * Review feedback: Add allocation counter to rbtree * Review feedback: also test mixed blocks and unboxed float blocks in the lift constants test * Review feedback: as discussed in meeting * Review feedback * Overwriting typing (#3157) * First draft of type checking * Check in uniqueness analysis that tags stay the same during overwriting * Report a syntax error on overwriting anything except an allocation * Full type-checking for tuples and records * Type checking fully implemented * Clean up type-checking and add ability to overwrite arbitrary expressions * Fix checking of tags * Test (labeled) tuples * Final tests and allow overwrite of inlined records * Review suggestion Co-authored-by: Richard Eisenberg <[email protected]> * Review suggestion Co-authored-by: Richard Eisenberg <[email protected]> * Review feedback: add more tests * Uniqueness analysis: Change grammar of error message to indicate parallel evaluation * Review feedback: Fix typo Co-authored-by: Richard Eisenberg <[email protected]> * Review feedback: add comments and tests * Prevent nested allocations in overwrite * Review feedback: Fix comment and improve readability * Review feedback: add comments, tests and nicer error messages * Fix nested record bug * Improve code quality * Disallow overwriting of unboxed records * Review feedback * Clarify the overwriting state for type_label_exp * Add debugging printers for uniqueness Sadly this doesn't actually work in the debugger. * Temporarily allow unique mutable fields for better tests of overwriting tags (to be reverted) * New scheme for checking that overwrite does not change tags * Refactor: split up Learned_tags and Overwrites and use match_with_learned_tags instead of seq * Add comment about fold_left1 and zero of semiring * Fix submode error attribution in records * Tune errors in tag checker * Don't record tags that have been overwritten and matched with a learned tag * Review feedback: comments and small improvements * Review feedback: tune comments --------- Co-authored-by: Richard Eisenberg <[email protected]> Co-authored-by: Richard Eisenberg <[email protected]> * Revert c29a7bb to disable unique mutable fields again * Remove out-of-date CRs --------- Co-authored-by: Richard Eisenberg <[email protected]> Co-authored-by: Richard Eisenberg <[email protected]>
ocaml-flambda · Dec 6, 2024 · 5d8f1aa · 5d8f1aa
1 parent 2630db6
commit 5d8f1aa
Show file tree

Hide file tree

Showing 53 changed files with 3,819 additions and 399 deletions.
diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml
@@ -247,7 +247,7 @@ let iter_on_occurrences
       | Texp_object _ | Texp_pack _ | Texp_letop _ | Texp_unreachable
       | Texp_list_comprehension _ | Texp_array_comprehension _ | Texp_probe _
       | Texp_probe_is_enabled _ | Texp_exclave _
-      | Texp_open _ | Texp_src_pos -> ());
+      | Texp_open _ | Texp_src_pos | Texp_overwrite _ | Texp_hole _ -> ());
       default_iterator.expr sub e);
 
   (* Remark: some types get iterated over twice due to how constraints are

diff --git a/lambda/translcore.ml b/lambda/translcore.ml
@@ -1226,6 +1226,10 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         ]
       in
       Lconst(Const_block(0, cl))
+  | Texp_overwrite (_, _) ->
+      Location.todo_overwrite_not_implemented ~kind:"Translcore" e.exp_loc
+  | Texp_hole _ ->
+      Location.todo_overwrite_not_implemented ~kind:"Translcore" e.exp_loc
 
 and pure_module m =
   match m.mod_desc with

diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
@@ -250,6 +250,8 @@ module Exp = struct
   let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable
   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 hole ?loc ?attrs () = mk ?loc ?attrs Pexp_hole
 
   let case lhs ?guard rhs =
     {

diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
@@ -215,6 +215,8 @@ module Exp:
     val stack : ?loc:loc -> ?attrs:attrs -> expression -> expression
     val comprehension :
       ?loc:loc -> ?attrs:attrs -> comprehension_expression -> expression
+    val overwrite : ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression
+    val hole : ?loc:loc -> ?attrs:attrs -> unit -> expression
 
     val case: pattern -> ?guard:expression -> expression -> case
     val binding_op: str -> pattern -> expression -> loc -> binding_op

diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
@@ -535,6 +535,8 @@ module E = struct
     | Pexp_unreachable -> ()
     | 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_hole -> ()
 
   let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
     iter_loc sub pbop_op;

diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
@@ -613,6 +613,8 @@ module E = struct
     | Pexp_unreachable -> unreachable ~loc ~attrs ()
     | 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_hole -> hole ~loc ~attrs ()
 
   let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} =
     let open Exp in

diff --git a/parsing/depend.ml b/parsing/depend.ml
@@ -316,6 +316,8 @@ let rec add_expr bv exp =
       end
   | Pexp_extension e -> handle_extension e
   | Pexp_stack e -> add_expr bv e
+  | Pexp_overwrite (e1, e2) -> add_expr bv e1; add_expr bv e2
+  | Pexp_hole -> ()
   | Pexp_unreachable -> ()
   | Pexp_comprehension x -> add_comprehension_expr bv x
 

diff --git a/parsing/language_extension.ml b/parsing/language_extension.ml
@@ -63,6 +63,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
   | Comprehensions -> (module Unit)
   | Mode -> (module Maturity)
   | Unique -> (module Maturity)
+  | Overwriting -> (module Unit)
   | Include_functor -> (module Unit)
   | Polymorphic_parameters -> (module Unit)
   | Immutable_arrays -> (module Unit)
@@ -82,7 +83,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 | Layouts -> true
+  | Mode | Unique | Overwriting | Layouts -> true
   | Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays
   | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances ->
     false
@@ -98,6 +99,7 @@ module Exist_pair = struct
     | Pair (Comprehensions, ()) -> Beta
     | Pair (Mode, m) -> m
     | Pair (Unique, m) -> m
+    | Pair (Overwriting, ()) -> Alpha
     | Pair (Include_functor, ()) -> Stable
     | Pair (Polymorphic_parameters, ()) -> Stable
     | Pair (Immutable_arrays, ()) -> Stable
@@ -120,7 +122,7 @@ module Exist_pair = struct
     | Pair
         ( (( Comprehensions | Include_functor | Polymorphic_parameters
            | Immutable_arrays | Module_strengthening | Labeled_tuples
-           | Instances ) as ext),
+           | Instances | Overwriting ) as ext),
           _ ) ->
       to_string ext
 
@@ -137,6 +139,7 @@ module Exist_pair = struct
     | "unique" -> Some (Pair (Unique, Stable))
     | "unique_beta" -> Some (Pair (Unique, Beta))
     | "unique_alpha" -> Some (Pair (Unique, Alpha))
+    | "overwriting" -> Some (Pair (Overwriting, ()))
     | "include_functor" -> Some (Pair (Include_functor, ()))
     | "polymorphic_parameters" -> Some (Pair (Polymorphic_parameters, ()))
     | "immutable_arrays" -> Some (Pair (Immutable_arrays, ()))
@@ -161,6 +164,7 @@ let all_extensions =
   [ Pack Comprehensions;
     Pack Mode;
     Pack Unique;
+    Pack Overwriting;
     Pack Include_functor;
     Pack Polymorphic_parameters;
     Pack Immutable_arrays;
@@ -198,6 +202,7 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option =
   | Comprehensions, Comprehensions -> Some Refl
   | Mode, Mode -> Some Refl
   | Unique, Unique -> Some Refl
+  | Overwriting, Overwriting -> Some Refl
   | Include_functor, Include_functor -> Some Refl
   | Polymorphic_parameters, Polymorphic_parameters -> Some Refl
   | Immutable_arrays, Immutable_arrays -> Some Refl
@@ -207,7 +212,7 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option =
   | Labeled_tuples, Labeled_tuples -> Some Refl
   | Small_numbers, Small_numbers -> Some Refl
   | Instances, Instances -> Some Refl
-  | ( ( Comprehensions | Mode | Unique | Include_functor
+  | ( ( Comprehensions | Mode | Unique | Overwriting | Include_functor
       | Polymorphic_parameters | Immutable_arrays | Module_strengthening
       | Layouts | SIMD | Labeled_tuples | Small_numbers | Instances ),
       _ ) ->

diff --git a/parsing/language_extension.mli b/parsing/language_extension.mli
@@ -21,6 +21,7 @@ type 'a t = 'a Language_extension_kernel.t =
   | Comprehensions : unit t
   | Mode : maturity t
   | Unique : maturity t
+  | Overwriting : unit t
   | Include_functor : unit t
   | Polymorphic_parameters : unit t
   | Immutable_arrays : unit t

diff --git a/parsing/lexer.mll b/parsing/lexer.mll
@@ -80,6 +80,7 @@ let keyword_table =
     "once_", ONCE;
     "open", OPEN;
     "or", OR;
+    "overwrite_", OVERWRITE;
 (*  "parser", PARSER; *)
     "private", PRIVATE;
     "rec", REC;

diff --git a/parsing/location.ml b/parsing/location.ml
@@ -1101,3 +1101,7 @@ let () =
 
 let raise_errorf ?(loc = none) ?(sub = []) =
   Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt)))
+
+let todo_overwrite_not_implemented ?(kind = "") t =
+  alert ~kind t "Overwrite not implemented.";
+  assert false
diff --git a/parsing/location.mli b/parsing/location.mli
@@ -396,3 +396,6 @@ val raise_errorf: ?loc:t -> ?sub:msg list ->
 
 val report_exception: formatter -> exn -> unit
 (** Reraise the exception if it is unknown. *)
+
+(** CR uniqueness: remove this once overwriting is fully implemented *)
+val todo_overwrite_not_implemented : ?kind:string -> t -> 'a
diff --git a/parsing/parser.mly b/parsing/parser.mly
@@ -1016,6 +1016,7 @@ let maybe_pmod_constraint mode expr =
 %token OPEN                   "open"
 %token <string> OPTLABEL      "?label:" (* just an example *)
 %token OR                     "or"
+%token OVERWRITE              "overwrite_"
 /* %token PARSER              "parser" */
 %token PERCENT                "%"
 %token PLUS                   "+"
@@ -2818,10 +2819,8 @@ fun_expr:
     { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 }
   | fun_expr attribute
       { Exp.attr $1 $2 }
-/* BEGIN AVOID */
   | UNDERSCORE
-     { not_expecting $loc($1) "wildcard \"_\"" }
-/* END AVOID */
+    { mkexp ~loc:$sloc Pexp_hole }
   | mode=mode_legacy exp=seq_expr
      { mkexp_with_modes ~loc:$sloc ~exp ~cty:None ~modes:[mode] }
   | EXCLAVE seq_expr
@@ -2848,6 +2847,8 @@ fun_expr:
       { Pexp_try($3, $5), $2 }
   | TRY ext_attributes seq_expr WITH error
       { syntax_error() }
+  | OVERWRITE ext_attributes seq_expr WITH expr
+      { Pexp_overwrite($3, $5), $2 }
   | IF ext_attributes seq_expr THEN expr ELSE expr
       { Pexp_ifthenelse($3, $5, Some $7), $2 }
   | IF ext_attributes seq_expr THEN expr

diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
@@ -507,6 +507,8 @@ and expression_desc =
           - [BODY] is an expression.
           - [CLAUSES] is a series of [comprehension_clause].
     *)
+  | Pexp_overwrite of expression * expression (** overwrite_ exp with exp *)
+  | Pexp_hole (** _ *)
 
 and case =
     {

diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
@@ -1095,6 +1095,12 @@ and expression ctxt f x =
           (expression ctxt) body
     | Pexp_extension e -> extension ctxt f e
     | Pexp_unreachable -> pp f "."
+    | Pexp_overwrite (e1, e2) ->
+        (* Similar to the case of [Pexp_stack] *)
+        pp f "@[<hov2>overwrite_@ %a@ with@ %a@]"
+          (expression2 reset_ctxt) e1
+          (expression2 reset_ctxt) e2
+    | Pexp_hole -> pp f "_"
     | _ -> expression1 ctxt f x
 
 and expression1 ctxt f x =

diff --git a/parsing/printast.ml b/parsing/printast.ml
@@ -448,6 +448,12 @@ and expression i ppf x =
   | Pexp_comprehension c ->
       line i ppf "Pexp_comprehension\n";
       comprehension_expression i ppf c
+  | Pexp_overwrite (e1, e2) ->
+      line i ppf "Pexp_overwrite\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_hole ->
+    line i ppf "Pexp_hole"
 
 and comprehension_expression i ppf = function
   | Pcomp_array_comprehension (m, c) ->

diff --git a/printer/printast_with_mappings.ml b/printer/printast_with_mappings.ml
@@ -472,6 +472,12 @@ and expression i ppf x =
   | Pexp_comprehension c ->
       line i ppf "Pexp_comprehension\n";
       comprehension_expression i ppf c
+  | Pexp_overwrite (e1, e2) ->
+      line i ppf "Pexp_overwrite\n";
+      expression i ppf e1;
+      expression i ppf e2
+  | Pexp_hole ->
+      line i ppf "Pexp_hole"
   )
 
 and comprehension_expression i ppf = function

diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml
@@ -1201,3 +1201,39 @@ Line 2, characters 18-26:
                       ^^^^^^^^
 Error: Mode annotations on modules are not supported yet.
 |}]
+
+(***************)
+(* Overwriting *)
+
+
+let overwrite_tuple = function
+    (a, b) as t -> overwrite_ t with (b, _)
+
+type record = { a : int; b : int }
+
+let overwrite_record = function
+    { a; b } as t -> overwrite_ t with { b = a; a = _ }
+
+let overwrite_record = function
+    { a; b } as t -> overwrite_ t with { b = a }
+
+let ret_record () = { a = 1; b = 2 }
+
+let overwrite_record () =
+  overwrite_ (ret_record ()) with { b = a }
+
+type constructor = C of { a : int; b : int }
+
+let overwrite_constructor = function
+    C { a; b } as t -> overwrite_ t with C { b = a; a = _ }
+
+let overwrite_constructor = function
+    C { a; b } as t -> overwrite_ t with C { b = a }
+[%%expect{|
+Line 2, characters 19-43:
+2 |     (a, b) as t -> overwrite_ t with (b, _)
+                       ^^^^^^^^^^^^^^^^^^^^^^^^
+Alert Translcore: Overwrite not implemented.
+Uncaught exception: File "parsing/location.ml", line 1107, characters 2-8: Assertion failed
+
+|}]
diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml b/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml
@@ -125,9 +125,9 @@ Error: Unbound record field "Complex.z"
 (* PR#6608 *)
 #{ true with contents = 0 };;
 [%%expect{|
-Line 1, characters 3-7:
+Line 1, characters 0-27:
 1 | #{ true with contents = 0 };;
-       ^^^^
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This expression has type "bool" which is not a unboxed record type.
 |}];;
 

diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml
@@ -134,9 +134,9 @@ Error: Unbound record field "Complex.z"
 (* PR#6608 *)
 { true with contents = 0 };;
 [%%expect{|
-Line 1, characters 2-6:
+Line 1, characters 0-26:
 1 | { true with contents = 0 };;
-      ^^^^
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This expression has type "bool" which is not a record type.
 |}];;
 

diff --git a/testsuite/tests/typing-misc/wrong_kind.ml b/testsuite/tests/typing-misc/wrong_kind.ml
@@ -232,9 +232,9 @@ Error: This expression has type "'a -> Record.t" which is not a record type.
 let () =
   ignore { (Record.get ()) with a = 5 };;
 [%%expect{|
-Line 2, characters 11-26:
+Line 2, characters 9-39:
 2 |   ignore { (Record.get ()) with a = 5 };;
-               ^^^^^^^^^^^^^^^
+             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This expression has type "'a -> Record.t" which is not a record type.
 |}]