Add special mode handling for tuples in matches and let bindings (#38)

* Fix mode in for_multiple_match

lambda/matching.ml

@@ -3672,7 +3672,7 @@ let compile_flattened ~scopes repr partial ctx pmh =
       let lam, total = compile_match_nonempty ~scopes repr partial ctx b in
       compile_orhandlers (compile_match ~scopes repr partial) lam total ctx hs
 
-let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
+let do_for_multiple_match ~scopes loc paraml mode pat_act_list partial =
   let repr = None in
   let partial = check_partial pat_act_list partial in
   let raise_num, arg, pm1 =
@@ -3686,7 +3686,7 @@ let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
       | Total -> (-1, Default_environment.empty)
     in
     let loc = Scoped_location.of_location ~scopes loc in
-    let arg = Lprim (Pmakeblock (0, Immutable, None, Alloc_heap (* FIXME *)),
+    let arg = Lprim (Pmakeblock (0, Immutable, None, mode),
                      paraml, loc) in
     ( raise_num,
       arg,
@@ -3748,8 +3748,8 @@ let bind_opt (v, eo) k =
   | None -> k
   | Some e -> Lambda.bind Strict v e k
 
-let for_multiple_match ~scopes loc paraml pat_act_list partial =
+let for_multiple_match ~scopes loc paraml mode pat_act_list partial =
   let v_paraml = List.map param_to_var paraml in
   let paraml = List.map (fun (v, _) -> Lvar v) v_paraml in
   List.fold_right bind_opt v_paraml
-    (do_for_multiple_match ~scopes loc paraml pat_act_list partial)
+    (do_for_multiple_match ~scopes loc paraml mode pat_act_list partial)

lambda/matching.mli

@@ -34,7 +34,7 @@ val for_let:
         lambda
 val for_multiple_match:
         scopes:scopes -> Location.t ->
-        lambda list -> (pattern * lambda) list -> partial ->
+        lambda list -> alloc_mode -> (pattern * lambda) list -> partial ->
         lambda
 
 val for_tupled_function:

lambda/translcore.ml

@@ -1188,8 +1188,9 @@ and transl_match ~scopes e arg pat_expr_list partial =
     match arg, exn_cases with
     | {exp_desc = Texp_tuple argl}, [] ->
       assert (static_handlers = []);
+      let mode = transl_value_mode arg.exp_mode in
       Matching.for_multiple_match ~scopes e.exp_loc
-        (transl_list ~scopes argl) val_cases partial
+        (transl_list ~scopes argl) mode val_cases partial
     | {exp_desc = Texp_tuple argl}, _ :: _ ->
         let val_ids =
           List.map
@@ -1200,9 +1201,10 @@ and transl_match ~scopes e arg pat_expr_list partial =
             argl
         in
         let lvars = List.map (fun (id, _) -> Lvar id) val_ids in
+        let mode = transl_value_mode arg.exp_mode in
         static_catch (transl_list ~scopes argl) val_ids
           (Matching.for_multiple_match ~scopes e.exp_loc
-             lvars val_cases partial)
+             lvars mode val_cases partial)
     | arg, [] ->
       assert (static_handlers = []);
       Matching.for_function ~scopes e.exp_loc

testsuite/tests/typing-local/local.ml

@@ -701,7 +701,7 @@ Error: This value escapes its region
 |}]
 
 
-
+(* raised exceptions must be global *)
 let no_leak_exn =
   use_locally (fun x -> let _exn = local_ Invalid_argument x in "bluh") "blah"
 [%%expect{|
@@ -717,6 +717,23 @@ Line 2, characters 66-67:
 Error: This value escapes its region
 |}]
 
+(* handled exceptions are known to be global *)
+let catch (f : unit -> local_ string) =
+  let a =
+    match f () with
+    | _ -> "hello"
+    | exception (Invalid_argument x) -> x
+  in
+  let b =
+    try let _ = f () in "hello" with
+    | Invalid_argument x -> x
+  in
+  (a, b)
+[%%expect{|
+val catch : (unit -> local_ string) -> string * string = <fun>
+|}]
+
+
 (* same, but this time the function is allowed to return its argument *)
 let use_locally (f : local_ 'a -> local_ 'a) : local_ 'a -> local_ 'a = f
 [%%expect{|
@@ -1430,6 +1447,93 @@ Error: Signature mismatch:
        The first is global and the second is not.
 |}]
 
+(* Special handling of tuples in matches and let bindings *)
+let escape : string -> unit = fun x -> ()
+
+let foo (local_ x) y =
+  match x, y with
+  | Some _, Some b -> escape b
+  | None, _ -> ()
+  | pr  -> let _, _ = pr in ();;
+[%%expect{|
+val escape : string -> unit = <fun>
+val foo : local_ 'a option -> string option -> unit = <fun>
+|}]
+
+let foo (local_ x) y =
+  let pr = x, y in
+  match pr with
+  | Some _, Some b -> escape b
+  | None, _ -> ()
+  | _  -> ();;
+[%%expect{|
+Line 4, characters 29-30:
+4 |   | Some _, Some b -> escape b
+                                 ^
+Error: This value escapes its region
+|}]
+
+let foo (local_ x) y =
+  match x, y with
+  | pr ->
+    let _, b = pr in
+    escape b
+  | _  -> ();;
+[%%expect{|
+Line 5, characters 11-12:
+5 |     escape b
+               ^
+Error: This value escapes its region
+|}]
+
+let foo p (local_ x) y z =
+  let (_, b) as pr =
+    if p then x, y else z
+  in
+  let _, _ = pr in
+  escape b;;
+[%%expect{|
+val foo : bool -> local_ 'a -> string -> 'a * string -> unit = <fun>
+|}]
+
+let foo p (local_ x) y (local_ z) =
+  let _, b =
+    if p then x, y else z
+  in
+  escape b;;
+[%%expect{|
+Line 5, characters 9-10:
+5 |   escape b;;
+             ^
+Error: This value escapes its region
+|}]
+
+let foo p (local_ x) y z =
+  let a, _ =
+    if p then x, y else z
+  in
+  escape a;;
+[%%expect{|
+Line 5, characters 9-10:
+5 |   escape a;;
+             ^
+Error: This value escapes its region
+|}]
+
+let foo p (local_ x) y z =
+  let pr =
+    if p then x, y else z
+  in
+  let _, b = pr in
+  escape b;;
+[%%expect{|
+Line 6, characters 9-10:
+6 |   escape b;;
+             ^
+Error: This value escapes its region
+|}]
+
+
 (* In debug mode, Gc.minor () checks for minor heap->local pointers *)
 let () = Gc.minor ()
 [%%expect{|