Only take the upper bounds of modes associated with allocations (#37)

Author: lpw25

lambda/translcore.ml

@@ -86,7 +86,7 @@ let extract_float = function
 
 let transl_value_mode mode : Lambda.alloc_mode =
   let alloc_mode = Types.Value_mode.regional_to_global_alloc mode in
-  match Types.Alloc_mode.constrain_upper alloc_mode with
+  match Types.Alloc_mode.constrain_lower alloc_mode with
   | Global -> Alloc_heap
   | Local -> Alloc_local
 

testsuite/tests/basic-modules/anonymous.ocamlc.reference

@@ -16,9 +16,8 @@
         (let (f = (function param 0) s = (makemutable 0 ""))
           (seq
             (ignore
-              (let (region *match* = (setfield_ptr 0 s "Hello World!"))
+              (let (*match* = (setfield_ptr 0 s "Hello World!"))
                 (makeblock 0)))
             (let
-              (drop = (function param 0)
-               region *match* = (apply drop (field 0 s)))
+              (drop = (function param 0) *match* = (apply drop (field 0 s)))
               (makeblock 0 A B f s drop))))))))

testsuite/tests/basic-modules/anonymous.ocamlopt.reference

@@ -18,13 +18,13 @@
         (setfield_ptr(root-init) 3 (global Anonymous!) s))
       (ignore
         (let
-          (region *match* =
+          (*match* =
              (setfield_ptr 0 (field 3 (global Anonymous!)) "Hello World!"))
           (makeblock 0)))
       (let (drop = (function param 0))
         (setfield_ptr(root-init) 4 (global Anonymous!) drop))
       (let
-        (region *match* =
+        (*match* =
            (apply (field 4 (global Anonymous!))
              (field 0 (field 3 (global Anonymous!)))))
         0)

testsuite/tests/basic/patmatch_for_multiple.ml

@@ -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 (region (ignore x/94)) 1)))
+   with (5 x/94) (seq (ignore x/94) 1)))
 - : bool = false
 |}];;

testsuite/tests/lib-buffer/test.ml

@@ -155,17 +155,12 @@ 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 as x ->
-      escape x;
-      failed (sprintf "%s of U+%04X" msg (Uchar.to_int u))
+    | false -> 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,7 +1,6 @@
 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,15 +5,12 @@
     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 as x -> escape x
+    | false -> ()
     | true -> loop (i + 1)
   in loop 0
 ;;

typing/typecore.ml

@@ -277,6 +277,22 @@ let eqmode ~loc ~env m1 m2 err =
   | Ok () -> ()
   | Error () -> raise (Error(loc, env, err))
 
+let allocations : Alloc_mode.t list ref = ref []
+
+let reset_allocations () = allocations := []
+
+let register_allocation expected_mode =
+  let alloc_mode = Value_mode.regional_to_global_alloc expected_mode.mode in
+  match Alloc_mode.check_const alloc_mode with
+  | Some _ -> ()
+  | None -> allocations := alloc_mode :: !allocations
+
+let optimise_allocations () =
+  List.iter
+    (fun mode -> ignore (Alloc_mode.constrain_upper mode))
+    !allocations;
+  reset_allocations ()
+
 (* Typing of constants *)
 
 let type_constant = function
@@ -2882,6 +2898,7 @@ and type_expect_
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_constant(Pconst_string (str, _, _) as cst) ->
+    register_allocation expected_mode;
     let cst = constant_or_raise env loc cst in
     (* Terrible hack for format strings *)
     let ty_exp = expand_head env ty_expected in
@@ -3107,6 +3124,7 @@ and type_expect_
         exp_env = env }
   | Pexp_tuple sexpl ->
       assert (List.length sexpl >= 2);
+      register_allocation expected_mode;
       let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
       let to_unify = newgenty (Ttuple subtypes) in
       with_explanation (fun () ->
@@ -3131,6 +3149,8 @@ and type_expect_
         sarg ty_expected_explained sexp.pexp_attributes
   | Pexp_variant(l, sarg) ->
       (* Keep sharing *)
+      if sarg <> None then
+        register_allocation expected_mode;
       let ty_expected0 = instance ty_expected in
       let argument_mode = mode_subcomponent expected_mode in
       begin try match
@@ -3168,6 +3188,7 @@ and type_expect_
       end
   | Pexp_record(lid_sexp_list, opt_sexp) ->
       assert (lid_sexp_list <> []);
+      register_allocation expected_mode;
       let opt_exp =
         match opt_sexp with
           None -> None
@@ -3347,6 +3368,7 @@ and type_expect_
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_array(sargl) ->
+      register_allocation expected_mode;
       let ty = newgenvar() in
       let to_unify = Predef.type_array ty in
       with_explanation (fun () ->
@@ -3842,6 +3864,7 @@ and type_expect_
         exp_env = env;
       }
   | Pexp_lazy e ->
+      register_allocation expected_mode;
       let closure_mode = Value_mode.regional_to_global expected_mode.mode in
       let ty = newgenvar () in
       let to_unify = Predef.type_lazy_t ty in
@@ -4157,6 +4180,7 @@ and type_binding_op_ident env s =
 and type_function ?in_function loc attrs env expected_mode
       ty_expected_explained l has_local caselist =
   let { ty = ty_expected; explanation } = ty_expected_explained in
+  register_allocation expected_mode;
   let alloc_mode = Value_mode.regional_to_global_alloc expected_mode.mode in
   let (loc_fun, ty_fun) =
     match in_function with
@@ -4964,6 +4988,8 @@ and type_application env app_loc expected_mode funct funct_mode sargs =
 
 and type_construct env expected_mode loc lid sarg ty_expected_explained attrs =
   let { ty = ty_expected; explanation } = ty_expected_explained in
+  if sarg <> None then
+    register_allocation expected_mode;
   let argument_mode = mode_subcomponent expected_mode in
   let expected_type =
     try

typing/typecore.mli

@@ -127,6 +127,10 @@ val generalizable: int -> type_expr -> bool
 val reset_delayed_checks: unit -> unit
 val force_delayed_checks: unit -> unit
 
+val reset_allocations: unit -> unit
+val optimise_allocations: unit -> unit
+
+
 val name_pattern : string -> Typedtree.pattern list -> Ident.t
 val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t
 

typing/typemod.ml

@@ -2458,12 +2458,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
   if toplevel then run ()
   else Builtin_attributes.warning_scope [] run
 
-let type_toplevel_phrase env s =
-  Env.reset_required_globals ();
-  let (str, sg, to_remove_from_sg, env) =
-    type_structure ~toplevel:true false None env s in
-  remove_mode_variables env sg;
-  begin match str.str_items with
+(* The toplevel will print some types not present in the signature *)
+let remove_mode_variables_for_toplevel str =
+  match str.str_items with
   | [{ str_desc =
          ( Tstr_eval (exp, _)
          | Tstr_value (Nonrecursive,
@@ -2473,7 +2470,15 @@ let type_toplevel_phrase env s =
         even though they do not appear in sg *)
      Ctype.remove_mode_variables exp.exp_type
   | _ -> ()
-  end;
+
+let type_toplevel_phrase env s =
+  Env.reset_required_globals ();
+  Typecore.reset_allocations ();
+  let (str, sg, to_remove_from_sg, env) =
+    type_structure ~toplevel:true false None env s in
+  remove_mode_variables env sg;
+  remove_mode_variables_for_toplevel str;
+  Typecore.optimise_allocations ();
   (str, sg, to_remove_from_sg, env)
 
 let type_module_alias = type_module ~alias:true true false None
@@ -2649,6 +2654,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
   Cmt_format.clear ();
   Misc.try_finally (fun () ->
       Typecore.reset_delayed_checks ();
+      Typecore.reset_allocations ();
       Env.reset_required_globals ();
       if !Clflags.print_types then (* #7656 *)
         Warnings.parse_options false "-32-34-37-38-60";
@@ -2657,6 +2663,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
       let simple_sg = Signature_names.simplify finalenv names sg in
       if !Clflags.print_types then begin
         Typecore.force_delayed_checks ();
+        Typecore.optimise_allocations ();
         Printtyp.wrap_printing_env ~error:false initial_env
           (fun () -> fprintf std_formatter "%a@."
               (Printtyp.printed_signature sourcefile) simple_sg
@@ -2679,6 +2686,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
               sourcefile sg intf_file dclsig
           in
           Typecore.force_delayed_checks ();
+          Typecore.optimise_allocations ();
           (* It is important to run these checks after the inclusion test above,
              so that value declarations which are not used internally but
              exported are not reported as being unused. *)
@@ -2695,6 +2703,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
           check_nongen_schemes finalenv simple_sg;
           normalize_signature simple_sg;
           Typecore.force_delayed_checks ();
+          Typecore.optimise_allocations ();
           (* See comment above. Here the target signature contains all
              the value being exported. We can still capture unused
              declarations like "let x = true;; let x = 1;;", because in this