Overwriting typing

ocaml/testsuite/tests/typing-unique/overwriting.ml

@@ -487,9 +487,70 @@ Uncaught exception: File "ocaml/parsing/location.ml", line 1106, characters 2-8:
 (*******************************)
 (* Overwriting inlined records *)
 
-(* CR uniqueness *)
+type constructor_update = Con of { x : string; y : string }
+[%%expect{|
+type constructor_update = Con of { x : string; y : string; }
+|}]
+
+let update = function
+  | (Con _ as c) ->
+    let x = overwrite_ c with Con { x = "foo" } in
+    x
+[%%expect{|
+Line 3, characters 12-47:
+3 |     let x = overwrite_ c with Con { x = "foo" } in
+                ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Alert Translcore: Overwrite not implemented.
+Uncaught exception: File "ocaml/parsing/location.ml", line 1106, characters 2-8: Assertion failed
+
+|}]
 
-(******************************)
-(* Overwriting mutable fields *)
+let update = function
+  | (Con c1 as c) ->
+    let x = overwrite_ c with Con { c1 with x = "foo" } in
+    x
+[%%expect{|
+Line 3, characters 12-55:
+3 |     let x = overwrite_ c with Con { c1 with x = "foo" } in
+                ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Alert Translcore: Overwrite not implemented.
+Uncaught exception: File "ocaml/parsing/location.ml", line 1106, characters 2-8: Assertion failed
 
-(* CR uniqueness *)
+|}]
+
+let update = function
+  | (Con c) ->
+    let x = overwrite_ c with { x = "foo" } in
+    x
+[%%expect{|
+Line 3, characters 23-24:
+3 |     let x = overwrite_ c with { x = "foo" } in
+                           ^
+Error: This form is not allowed as the type of the inlined record could escape.
+|}]
+
+let update = function
+  | (Con c) ->
+    let x = Con (overwrite_ c with { x = "foo" }) in
+    x
+[%%expect{|
+Line 3, characters 16-49:
+3 |     let x = Con (overwrite_ c with { x = "foo" }) in
+                    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Alert Translcore: Overwrite not implemented.
+Uncaught exception: File "ocaml/parsing/location.ml", line 1106, characters 2-8: Assertion failed
+
+|}]
+
+let update = function
+  | (Con c) ->
+    let x = Con (overwrite_ c with { c with x = "foo" }) in
+    x
+[%%expect{|
+Line 3, characters 16-56:
+3 |     let x = Con (overwrite_ c with { c with x = "foo" }) in
+                    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Alert Translcore: Overwrite not implemented.
+Uncaught exception: File "ocaml/parsing/location.ml", line 1106, characters 2-8: Assertion failed
+
+|}]

ocaml/testsuite/tests/typing-unique/overwriting_proj_push_down_bug.ml

@@ -328,6 +328,22 @@ let swap_inner (t : tree) =
 val swap_inner : tree -> tree @@ global many = <fun>
 |}]
 
+(* CR uniqueness: Update this test once overwriting is fully implemented.
+   let swap_inner (t : tree) =
+   match t with
+   | Node { l = Node { r = lr } as l; r = Node { l = rl } as r } as t ->
+   overwrite_ t with
+   Node { l = overwrite_ l with Node { r = rl; };
+   r = overwrite_ r with Node { l = lr; }}
+   | _ -> t
+   [%%expect{|
+
+   |}]
+*)
+
+(***********************)
+(* Barriers for guards *)
+
 let match_guard r =
   match r with
   | { y } when String.equal y "" ->
@@ -376,15 +392,69 @@ Line 3, characters 41-42:
 
 |}]
 
-(* CR uniqueness: Update this test once overwriting is fully implemented.
-let swap_inner (t : tree) =
-  match t with
-  | Node { l = Node { r = lr } as l; r = Node { l = rl } as r } as t ->
-      overwrite_ t with
-        Node { l = overwrite_ l with Node { r = rl; };
-               r = overwrite_ r with Node { l = lr; }}
-  | _ -> t
+(********************************************)
+(* Global allocations in overwritten fields *)
+
+type option_record = { x : string option; y : string option @@ many aliased }
+[%%expect{|
+0
+type option_record = {
+  x : string option;
+  y : string option @@ many aliased;
+}
+|}]
+
+let check_heap_alloc_in_overwrite (unique_ r : option_record) =
+  overwrite_ r with { x = Some "" }
 [%%expect{|
+Line 2, characters 2-35:
+2 |   overwrite_ r with { x = Some "" }
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Alert Translcore: Overwrite not implemented.
+Uncaught exception: File "ocaml/parsing/location.ml", line 1106, characters 2-8: Assertion failed
+
+|}]
+
+let check_heap_alloc_in_overwrite (unique_ r : option_record) =
+  overwrite_ r with { y = Some "" }
+[%%expect{|
+Line 2, characters 2-35:
+2 |   overwrite_ r with { y = Some "" }
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Alert Translcore: Overwrite not implemented.
+Uncaught exception: File "ocaml/parsing/location.ml", line 1106, characters 2-8: Assertion failed
+
+|}]
+
+(*******************************)
+(* Overwrite of mutable fields *)
+
+type mutable_record = { mutable x : string; y : string }
+[%%expect{|
+0
+type mutable_record = { mutable x : string; y : string; }
+|}]
+
+let update (unique_ r : mutable_record) =
+  let x = overwrite_ r with { x = "foo" } in
+x.x
+[%%expect{|
+Line 2, characters 10-41:
+2 |   let x = overwrite_ r with { x = "foo" } in
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Alert Translcore: Overwrite not implemented.
+Uncaught exception: File "ocaml/parsing/location.ml", line 1106, characters 2-8: Assertion failed
+
+|}]
+
+let update (unique_ r : mutable_record) =
+  let x = overwrite_ r with { y = "foo" } in
+x.x
+[%%expect{|
+Line 2, characters 10-41:
+2 |   let x = overwrite_ r with { y = "foo" } in
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Alert Translcore: Overwrite not implemented.
+Uncaught exception: File "ocaml/parsing/location.ml", line 1106, characters 2-8: Assertion failed
 
 |}]
-*)

ocaml/testsuite/tests/typing-unique/overwriting_syntax.ml

@@ -3,6 +3,14 @@
    expect;
 *)
 
+(* CR uniqueness: It would be nice to also support the following syntactic forms:
+     overwrite_ e with (~x:5, ..)
+     overwrite_ e with { x = 4; _ }
+
+   This would require us to allow general patterns as the top-level second argument to
+   overwrite_ with. However, all overwritten fields should continue to be expressions.
+*)
+
 (******************)
 (* Usage examples *)
 

ocaml/typing/typecore.ml

@@ -6599,7 +6599,7 @@ and type_expect_
         { ty = newvar (Jkind.Builtin.value ~why:Boxed_record);
           explanation = None }
       in
-      let exp1 = type_expect env (mode_default cell_mode) exp1 cell_type in
+      let exp1 = type_expect ~recarg env (mode_default cell_mode) exp1 cell_type in
       let exp2 =
         (* The newly-written fields have to global to avoid heap-to-stack pointers.
            We enforce that here, by asking the allocation to be global.
@@ -6618,7 +6618,7 @@ and type_expect_
             |> Value.disallow_right
         in
         let overwrite = Overwriting (exp1.exp_loc, exp1.exp_type, fields_mode) in
-        type_expect ~overwrite env exp2_mode exp2 ty_expected_explained
+        type_expect ~recarg ~overwrite env exp2_mode exp2 ty_expected_explained
       in
       re { exp_desc = Texp_overwrite(exp1, exp2);
             exp_loc = loc; exp_extra = [];
@@ -8148,7 +8148,9 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg
       begin match sargs with
       | [{pexp_desc =
             Pexp_ident _ |
-            Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] ->
+            Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None)) |
+            Pexp_overwrite (_, {pexp_desc =
+              Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))})}] ->
         Required
       | _ ->
         raise (Error(loc, env, Inlined_record_expected))