Add some missing regions

lambda/simplif.ml

@@ -702,7 +702,7 @@ let rec emit_tail_infos is_tail lambda =
   | Lifused (_, lam) ->
       emit_tail_infos is_tail lam
   | Lregion lam ->
-      emit_tail_infos false lam
+      emit_tail_infos is_tail lam
 and list_emit_tail_infos_fun f is_tail =
   List.iter (fun x -> emit_tail_infos is_tail (f x))
 and list_emit_tail_infos is_tail =

lambda/translcore.ml

@@ -474,22 +474,24 @@ and transl_exp0 ~in_new_scope ~scopes e =
               of_location ~scopes e.exp_loc)
       end
   | Texp_ifthenelse(cond, ifso, Some ifnot) ->
-      Lifthenelse(transl_exp ~scopes cond,
+      Lifthenelse(transl_exp_maybe_region ~scopes cond,
                   event_before ~scopes ifso (transl_exp ~scopes ifso),
                   event_before ~scopes ifnot (transl_exp ~scopes ifnot))
   | Texp_ifthenelse(cond, ifso, None) ->
-      Lifthenelse(transl_exp ~scopes cond,
-                  event_before ~scopes ifso (transl_exp ~scopes ifso),
+      Lifthenelse(transl_exp_maybe_region ~scopes cond,
+                  event_before ~scopes ifso
+                    (transl_exp_maybe_region ~scopes ifso),
                   lambda_unit)
   | Texp_sequence(expr1, expr2) ->
-      Lsequence(transl_exp ~scopes expr1,
+      Lsequence(transl_exp_maybe_region ~scopes expr1,
                 event_before ~scopes expr2 (transl_exp ~scopes expr2))
   | Texp_while(cond, body) ->
-      Lwhile(transl_exp ~scopes cond,
-             event_before ~scopes body (transl_exp ~scopes body))
+      Lwhile(transl_exp_maybe_region ~scopes cond,
+             event_before ~scopes body (transl_exp_maybe_region ~scopes body))
   | Texp_for(param, _, low, high, dir, body) ->
-      Lfor(param, transl_exp ~scopes low, transl_exp ~scopes high, dir,
-           event_before ~scopes body (transl_exp ~scopes body))
+      Lfor(param, transl_exp_maybe_region ~scopes low,
+           transl_exp_maybe_region ~scopes high, dir,
+           event_before ~scopes body (transl_exp_maybe_region ~scopes body))
   | Texp_send(_, _, Some exp) -> transl_exp ~scopes exp
   | Texp_send(expr, met, None) ->
       let obj = transl_exp ~scopes expr in
@@ -572,8 +574,11 @@ and transl_exp0 ~in_new_scope ~scopes e =
   | Texp_assert (cond) ->
       if !Clflags.noassert
       then lambda_unit
-      else Lifthenelse (transl_exp ~scopes cond, lambda_unit,
-                        assert_failed ~scopes e)
+      else begin
+        Lifthenelse
+          (transl_exp_maybe_region ~scopes cond,
+           lambda_unit, assert_failed ~scopes e)
+      end
   | Texp_lazy e ->
       (* when e needs no computation (constants, identifiers, ...), we
          optimize the translation just as Lazy.lazy_from_val would
@@ -674,13 +679,18 @@ and transl_list_with_shape ~scopes expr_list =
   in
   List.split (List.map transl_with_shape expr_list)
 
+and transl_exp_maybe_region ~scopes e =
+  let mode = transl_value_mode e.exp_mode in
+  let lam = transl_exp ~scopes e in
+  maybe_region Alloc_heap [mode] lam
+
 and transl_guard ~scopes guard rhs =
   let expr = event_before ~scopes rhs (transl_exp ~scopes rhs) in
   match guard with
   | None -> expr
   | Some cond ->
       event_before ~scopes cond
-        (Lifthenelse(transl_exp ~scopes cond, expr, staticfail))
+        (Lifthenelse(transl_exp_maybe_region ~scopes cond, expr, staticfail))
 
 and transl_case ~scopes {c_lhs; c_guard; c_rhs} =
   c_lhs, transl_guard ~scopes c_guard c_rhs
@@ -1204,9 +1214,13 @@ and transl_match ~scopes e arg pat_expr_list partial =
           (Matching.for_function ~scopes e.exp_loc
              None (Lvar val_id) val_cases partial)
   in
-  List.fold_left (fun body (static_exception_id, val_ids, handler) ->
-    Lstaticcatch (body, (static_exception_id, val_ids), handler)
-  ) classic static_handlers
+  let lam =
+    List.fold_left (fun body (static_exception_id, val_ids, handler) ->
+      Lstaticcatch (body, (static_exception_id, val_ids), handler)
+    ) classic static_handlers
+  in
+  let bound_modes = [transl_value_mode arg.exp_mode] in
+  maybe_region (transl_value_mode e.exp_mode) bound_modes lam
 
 and transl_letop ~scopes loc env let_ ands param case partial =
   let rec loop prev_lam = function

testsuite/tests/basic/patmatch_for_multiple.ml

@@ -12,7 +12,7 @@ match (3, 2, 1) with
 ;;
 [%%expect{|
 (let
-  (*match*/88 = 3
+  (region *match*/88 = 3
    *match*/89 = 2
    *match*/90 = 1
    *match*/91 = *match*/88
@@ -54,6 +54,6 @@ match (3, 2, 1) with
                *match*/103 =a (field 1 *match*/99))
               (exit 5 *match*/99)))))
      with (6) 0)
-   with (5 x/94) (seq (ignore x/94) 1)))
+   with (5 x/94) (seq (region (ignore x/94)) 1)))
 - : bool = false
 |}];;

testsuite/tests/lib-buffer/test.ml

@@ -155,12 +155,17 @@ let uchar_map_of_spec spec =
   map
 ;;
 
+(* FIXME: Remove this once regions or tailcalls are fixed *)
+let escape : 'a -> unit = fun x -> ()
+
 let test_spec_map msg utf_x_map buffer_add_utf_x_uchar =
   let b = Buffer.create 4 in
   let rec loop u =
     Buffer.clear b; buffer_add_utf_x_uchar b u;
     match Buffer.contents b = utf_x_map.(Uchar.to_int u) with
-    | false -> failed (sprintf "%s of U+%04X" msg (Uchar.to_int u))
+    | false as x ->
+      escape x;
+      failed (sprintf "%s of U+%04X" msg (Uchar.to_int u))
     | true ->
         if Uchar.equal u Uchar.max then passed msg else loop (Uchar.succ u)
   in

testsuite/tests/lib-dynlink-initializers/test10_main.native.reference

@@ -1,6 +1,7 @@
 Error: Failure("Plugin error")
 Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33
 Called from Test10_plugin.g in file "test10_plugin.ml", line 2, characters 15-38
+Called from Test10_plugin.f in file "test10_plugin.ml", line 6, characters 2-6
 Called from Test10_plugin in file "test10_plugin.ml", line 10, characters 2-6
 Called from Dynlink.Native.run.(fun) in file "otherlibs/dynlink/native/dynlink.ml", line 85, characters 12-29
 Called from Dynlink.Native.run.(fun) in file "otherlibs/dynlink/native/dynlink.ml", line 85, characters 12-29

testsuite/tests/match-exception/tail_calls.ml

@@ -5,12 +5,15 @@
     The success continuation expression is in tail position.
 *)
 
+(* FIXME: Remove this once regions or tailcalls are fixed *)
+let escape : 'a -> unit = fun x -> ()
+
 let count_to_tr_match n =
   let rec loop i =
     match
       i < n
     with exception Not_found -> ()
-    | false -> ()
+    | false as x -> escape x
     | true -> loop (i + 1)
   in loop 0
 ;;

typing/typecore.ml

@@ -217,6 +217,12 @@ let mode_tail mode =
   let escaping_context = Some Return in
   { position; escaping_context; mode }
 
+let mode_var () =
+  let position = Nontail in
+  let escaping_context = None in
+  let mode = Value_mode.newvar () in
+  { position; escaping_context; mode }
+
 let mode_local =
   let position = Nontail in
   let escaping_context = None in
@@ -3339,12 +3345,12 @@ and type_expect_
         exp_env = env }
   | Pexp_ifthenelse(scond, sifso, sifnot) ->
       let cond =
-        type_expect env mode_local scond
+        type_expect env (mode_var ()) scond
           (mk_expected ~explanation:If_conditional Predef.type_bool)
       in
       begin match sifnot with
         None ->
-          let ifso = type_expect env expected_mode sifso
+          let ifso = type_expect env (mode_var ()) sifso
               (mk_expected ~explanation:If_no_else_branch Predef.type_unit) in
           rue {
             exp_desc = Texp_ifthenelse(cond, ifso, None);
@@ -3383,7 +3389,7 @@ and type_expect_
         exp_env = env }
   | Pexp_while(scond, sbody) ->
       let cond =
-        type_expect env mode_local scond
+        type_expect env (mode_var ()) scond
           (mk_expected ~explanation:While_loop_conditional Predef.type_bool)
       in
       let body = type_statement ~explanation:While_loop_body env sbody in
@@ -3396,11 +3402,11 @@ and type_expect_
         exp_env = env }
   | Pexp_for(param, slow, shigh, dir, sbody) ->
       let low =
-        type_expect env mode_local slow
+        type_expect env (mode_var ()) slow
           (mk_expected ~explanation:For_loop_start_index Predef.type_int)
       in
       let high =
-        type_expect env mode_local shigh
+        type_expect env (mode_var ()) shigh
           (mk_expected ~explanation:For_loop_stop_index Predef.type_int)
       in
       let id, new_env =
@@ -3788,7 +3794,7 @@ and type_expect_
 
   | Pexp_assert (e) ->
       let cond =
-        type_expect env mode_local e
+        type_expect env (mode_var ()) e
           (mk_expected ~explanation:Assert_condition Predef.type_bool)
       in
       let exp_type =
@@ -5018,7 +5024,7 @@ and type_construct env expected_mode loc lid sarg ty_expected_explained attrs =
 
 and type_statement ?explanation env sexp =
   begin_def();
-  let exp = type_exp env mode_local sexp in
+  let exp = type_exp env (mode_var ()) sexp in
   end_def();
   let ty = expand_head env exp.exp_type and tv = newvar() in
   if is_Tvar ty && ty.level > tv.level then
@@ -5238,7 +5244,7 @@ and type_cases
           | None -> None
           | Some scond ->
               Some
-                (type_unpacks ext_env mode_local unpacks scond
+                (type_unpacks ext_env (mode_var ()) unpacks scond
                    (mk_expected ~explanation:When_guard Predef.type_bool))
         in
         let exp =