flambda-backend: pattern match local iarray gives local elements(#1574)

testsuite/tests/typing-local/local.ml

@@ -1,4 +1,5 @@
 (* TEST
+   flags = "-extension immutable_arrays"
    * expect *)
 
 let leak n =
@@ -2509,38 +2510,98 @@ Line 3, characters 24-26:
 Error: This value escapes its region
 |}]
 
+(* Test of array.*)
 
-(* test of arrays *)
-(* as elements of arrays are mutable *)
-(* it is only safe for them to be at global mode *)
-(* cf: similarly reference cell can contain only global values *)
+(* Immutable arrays are like tuples or normal record: local array contains local
+elements, both at construction and at projection; global array contains global
+elements. *)
 
-(* on construction of array, we ensure elements are global *)
+(* constructing global iarray from local elements is rejected *)
+let f (local_ x : string) = ref [: x; "foo" :]
+[%%expect{|
+Line 1, characters 35-36:
+1 | let f (local_ x : string) = ref [: x; "foo" :]
+                                       ^
+Error: This value escapes its region
+|}]
+
+(* constructing local iarray from local elements is fine *)
+let f (local_ x : string) = local_ [:x; "foo":]
+[%%expect{|
+val f : local_ string -> local_ string iarray = <fun>
+|}]
+
+(* constructing global iarray from global elements is fine *)
+let f (x : string) = ref [:x; "foo":]
+[%%expect{|
+val f : string -> string iarray ref = <fun>
+|}]
 
-let f (local_ x : string) =
-  [|x; "foo"|]
+(* projecting out of local array gives local elements *)
+let f (local_ a : string iarray) =
+  match a with
+  | [: x; _ :] -> ref x
+  | _ -> ref "foo"
 [%%expect{|
-Line 2, characters 4-5:
-2 |   [|x; "foo"|]
-        ^
+Line 3, characters 22-23:
+3 |   | [: x; _ :] -> ref x
+                          ^
 Error: This value escapes its region
 |}]
 
-let f (x : string) =
-  [|x; "foo"|]
+(* a test that was passing type check *)
+let unsafe_globalize (local_ s : string) : string =
+  match local_ [:s:] with
+  | [:s':] -> s'
+  | _ -> assert false
+[%%expect{|
+Line 3, characters 14-16:
+3 |   | [:s':] -> s'
+                  ^^
+Error: This local value escapes its region
+  Hint: Cannot return local value without an explicit "local_" annotation
+|}]
+
+let f (local_ a : string iarray) =
+  match a with
+  | [: x; _ :] -> x
+  | _ -> "foo"
+[%%expect{|
+val f : local_ string iarray -> local_ string = <fun>
+|}]
+
+(* projecting out of global iarray gives global elements *)
+let f (a : string iarray) =
+  match a with
+  | [: x :] -> ref x
+  | _ -> ref "foo"
+[%%expect{|
+val f : string iarray -> string ref = <fun>
+|}]
+
+(* Mutable array, like references, is dangerous. They must contain global
+    elements regardless of the array's mode. *)
+
+(* constructing local array from local elements is rejected *)
+let f (local_ x : string) = local_ [| x |]
 [%%expect{|
-val f : string -> string array = <fun>
+Line 1, characters 38-39:
+1 | let f (local_ x : string) = local_ [| x |]
+                                          ^
+Error: This value escapes its region
 |}]
 
+(* constructing local array from global elements is allowed *)
+let f (x : string) = local_ [| x |]
+[%%expect{|
+val f : string -> local_ string array = <fun>
+|}]
 
-(* on pattern matching of array,
-   elements are strengthened to global
-  even if array itself is local *)
+(* projecting out of local array gives global elements *)
 let f (local_ a : string array) =
   match a with
-  | [| x; _ |] -> ref x
+  | [| x |] -> ref x
   | _ -> ref "foo"
-
 [%%expect{|
 val f : local_ string array -> string ref = <fun>
 |}]

typing/typecore.ml

@@ -2275,14 +2275,19 @@ and type_pat_aux
        shouldn't be too bad.  We can inline this when we upstream this code and
        combine the two array pattern constructors. *)
     let ty_elt = solve_Ppat_array ~refine loc env mutability expected_ty in
-      map_fold_cont (fun p -> type_pat ~alloc_mode:(simple_pat_mode Value_mode.global)
-       tps Value p ty_elt) spl (fun pl ->
-        rvp k {
-        pat_desc = Tpat_array (mutability, pl);
-        pat_loc = loc; pat_extra=[];
-        pat_type = instance expected_ty;
-        pat_attributes;
-        pat_env = !env })
+      map_fold_cont (fun p ->
+        let alloc_mode =
+          match mutability with
+          | Mutable -> simple_pat_mode Value_mode.global
+          | Immutable -> alloc_mode
+        in
+        type_pat ~alloc_mode tps Value p ty_elt) spl (fun pl ->
+          rvp k {
+          pat_desc = Tpat_array (mutability, pl);
+          pat_loc = loc; pat_extra=[];
+          pat_type = instance expected_ty;
+          pat_attributes;
+          pat_env = !env })
   in
   match Jane_syntax.Pattern.of_ast sp with
   | Some (jpat, attrs) -> begin