Recover ocaml-flambda#2669 (Tail-position local_ no longer means loca…

…l-returning) (ocaml-flambda#2842)
lukemaurer · Jul 24, 2024 · c4a01e9 · c4a01e9
1 parent 60739c1
commit c4a01e9
Show file tree

Hide file tree

Showing 34 changed files with 280 additions and 473 deletions.
diff --git a/chamelon/compat.jst.ml b/chamelon/compat.jst.ml
@@ -88,7 +88,6 @@ type texp_function = {
 type texp_function_identifier = {
   alloc_mode : Alloc.r;
   ret_sort : Jkind.sort;
-  region : bool;
   ret_mode : Alloc.l;
   zero_alloc : Zero_alloc.t;
 }
@@ -116,7 +115,6 @@ let texp_function_defaults =
     alloc_mode = Alloc.disallow_left Alloc.legacy;
     ret_sort = Jkind.Sort.value;
     ret_mode = Alloc.disallow_right Alloc.legacy;
-    region = false;
     zero_alloc = Zero_alloc.default;
   }
 
@@ -170,7 +168,6 @@ let mkTexp_function ?(id = texp_function_defaults)
                 fc_loc = Location.none;
               });
       alloc_mode = id.alloc_mode;
-      region = id.region;
       ret_sort = id.ret_sort;
       ret_mode = id.ret_mode;
       zero_alloc = id.zero_alloc;
@@ -225,8 +222,8 @@ let view_texp (e : expression_desc) =
   | Texp_tuple (args, mode) ->
       let labels, args = List.split args in
       Texp_tuple (args, (labels, mode))
-  | Texp_function
-      { params; body; alloc_mode; region; ret_sort; ret_mode; zero_alloc } ->
+  | Texp_function { params; body; alloc_mode; ret_sort; ret_mode; zero_alloc }
+    ->
       let params =
         List.map
           (fun param ->
@@ -273,8 +270,7 @@ let view_texp (e : expression_desc) =
               }
       in
       Texp_function
-        ( { params; body },
-          { alloc_mode; region; ret_sort; ret_mode; zero_alloc } )
+        ({ params; body }, { alloc_mode; ret_sort; ret_mode; zero_alloc })
   | Texp_sequence (e1, sort, e2) -> Texp_sequence (e1, e2, sort)
   | Texp_match (e, sort, cases, partial) -> Texp_match (e, cases, partial, sort)
   | _ -> O e

diff --git a/ocaml/lambda/tmc.ml b/ocaml/lambda/tmc.ml
@@ -36,7 +36,7 @@ type ambiguous_arguments = {
 
 type error =
   | Ambiguous_constructor_arguments of ambiguous_arguments
-  | Tmc_without_region
+  | Tmc_local_returning
 
 exception Error of Location.t * error
 
@@ -564,10 +564,12 @@ let llets lk vk bindings body =
 let find_candidate = function
   | Lfunction lfun when lfun.attr.tmc_candidate ->
      (* TMC does not make sense for local-returning functions *)
-     if not lfun.region then
+     begin match lfun.ret_mode with
+     | Alloc_local ->
        raise (Error (Debuginfo.Scoped_location.to_location lfun.loc,
-                     Tmc_without_region));
-     Some lfun
+                     Tmc_local_returning))
+     | Alloc_heap -> Some lfun
+     end
   | _ -> None
 
 let declare_binding ctx (var, def) =
@@ -718,7 +720,7 @@ let rec choice ctx t =
             else Default_tailcall
           in
           (* This application is in tail position of a region=true function
-             (or Tmc_without_region would have occurred), so it must be Heap *)
+             (or Tmc_local_returning would have occurred), so it must be Heap *)
           assert (Lambda.is_heap_mode apply.ap_mode);
           {
             Choice.dps = Dps.make (fun ~tail ~dst ->
@@ -1133,7 +1135,7 @@ let () =
             |> List.map sub
           in
           Some (Location.errorf ~loc ~sub:submgs "%t" print_msg)
-      | Error (loc, Tmc_without_region) ->
+      | Error (loc, Tmc_local_returning) ->
           Some (Location.errorf ~loc
                   "[@tail_mod_cons]: Functions cannot be both local-returning \
                    and [@tail_mod_cons]")

diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml
@@ -309,7 +309,7 @@ let fuse_method_arity (parent : fusable_function) : fusable_function =
         body = method_.body;
         return_mode = transl_alloc_mode_l method_.ret_mode;
         return_sort = method_.ret_sort;
-        region = method_.region;
+        region = true;
       }
   | _ -> parent
 
@@ -412,10 +412,10 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
       let return_layout = layout_exp sort body in
       transl_let ~scopes ~return_layout rec_flag pat_expr_list
         (event_before ~scopes body (transl_exp ~scopes sort body))
-  | Texp_function { params; body; region; ret_sort; ret_mode; alloc_mode;
+  | Texp_function { params; body; ret_sort; ret_mode; alloc_mode;
                     zero_alloc } ->
       transl_function ~in_new_scope ~scopes e params body
-        ~alloc_mode ~ret_mode ~ret_sort ~region ~zero_alloc
+        ~alloc_mode ~ret_mode ~ret_sort ~region:true ~zero_alloc
   | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p},
                                        Id_prim (pmode, psort), _);
                  exp_type = prim_type; } as funct,