Refactor toplevel local escape check (ocaml-flambda#104)

Author: stedolan

testsuite/tests/typing-local/local.ml

@@ -673,9 +673,9 @@ val local_closure : unit -> unit = <fun>
  *)
 let toplevel_stack = local_ {contents=42}
 [%%expect{|
-Line 1, characters 4-18:
+Line 1, characters 21-41:
 1 | let toplevel_stack = local_ {contents=42}
-        ^^^^^^^^^^^^^^
+                         ^^^^^^^^^^^^^^^^^^^^
 Error: This value escapes its region
 |}]
 
@@ -688,9 +688,9 @@ module M : sig end
 
 let _ = local_ {contents=42}
 [%%expect{|
-Line 1, characters 4-5:
+Line 1, characters 8-28:
 1 | let _ = local_ {contents=42}
-        ^
+            ^^^^^^^^^^^^^^^^^^^^
 Error: This value escapes its region
 |}]
 
@@ -2603,4 +2603,4 @@ let f (local_ a : string array) =
 
 [%%expect{|
 val f : local_ string array -> string ref = <fun>
-|}]  
+|}]  

typing/typecore.ml

@@ -6341,6 +6341,7 @@ and type_cases
 and type_let
     ?(check = fun s -> Warnings.Unused_var s)
     ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    ?(force_global = false)
     existential_context
     env rec_flag spat_sexp_list allow =
   let open Ast_helper in
@@ -6392,7 +6393,9 @@ and type_let
            | _ -> spat
          in
          let pat_mode, exp_mode =
-           match rec_mode_var with
+           if force_global
+           then simple_pat_mode Value_mode.global, mode_global
+           else match rec_mode_var with
            | None -> begin
                match pat_tuple_arity spat with
                | Not_local_tuple | Maybe_local_tuple ->
@@ -6813,12 +6816,13 @@ and type_andops env sarg sands expected_ty =
 
 (* Typing of toplevel bindings *)
 
-let type_binding env rec_flag spat_sexp_list =
+let type_binding env rec_flag ?force_global spat_sexp_list =
   Typetexp.TyVarEnv.reset ();
   let (pat_exp_list, new_env, _unpacks) =
     type_let
       ~check:(fun s -> Warnings.Unused_value_declaration s)
       ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+      ?force_global
       At_toplevel
       env rec_flag spat_sexp_list false
   in

typing/typecore.mli

@@ -102,6 +102,7 @@ type existential_restriction =
 
 val type_binding:
         Env.t -> rec_flag ->
+          ?force_global:bool ->
           Parsetree.value_binding list ->
           Typedtree.value_binding list * Env.t
 val type_let:

typing/typemod.ml

@@ -2546,17 +2546,16 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr =
         in
         Tstr_eval (expr, attrs), [], shape_map, env
     | Pstr_value(rec_flag, sdefs) ->
+        let force_global =
+          (* Values bound by '_' still escape in the toplevel, because
+             they may be printed even though they are not named *)
+          Option.is_some toplevel
+        in
         let (defs, newenv) =
-          Typecore.type_binding env rec_flag sdefs in
+          Typecore.type_binding env rec_flag ~force_global sdefs in
         let () = if rec_flag = Recursive then
           Typecore.check_recursive_bindings env defs
         in
-        if Option.is_some toplevel then begin
-          (* Values bound by '_' still escape in the toplevel, because
-              they may be printed even though they are not named *)
-          defs |> List.iter (fun vb ->
-            Typecore.escape ~loc:vb.vb_pat.pat_loc ~env:newenv vb.vb_expr.exp_mode);
-        end;
         (* Note: Env.find_value does not trigger the value_used event. Values
            will be marked as being used during the signature inclusion test. *)
         let items, shape_map =