diff --git a/boot/ocamlc b/boot/ocamlc index c8cbf9590a75..ec8bb58d3b8a 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamllex b/boot/ocamllex index d374ea860ca7..72a36f9faeff 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference b/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference index 495920f936ad..c7d1a4f2fdef 100644 --- a/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference +++ b/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference @@ -126,7 +126,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) Nolabel expression (test_locations.ml[19,572+13]..test_locations.ml[19,572+20]) - value_mode global + value_mode Texp_apply apply_mode Default expression (test_locations.ml[19,572+16]..test_locations.ml[19,572+17]) @@ -158,7 +158,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) Nolabel expression (test_locations.ml[19,572+27]..test_locations.ml[19,572+34]) - value_mode global + value_mode Texp_apply apply_mode Default expression (test_locations.ml[19,572+30]..test_locations.ml[19,572+31]) diff --git a/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference b/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference index 2868101d6bbf..4656cb8d42b2 100644 --- a/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference +++ b/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference @@ -126,7 +126,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) Nolabel expression - value_mode global + value_mode Texp_apply apply_mode Default expression @@ -158,7 +158,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) Nolabel expression - value_mode global + value_mode Texp_apply apply_mode Default expression diff --git a/testsuite/tests/typing-local/crossing.ml b/testsuite/tests/typing-local/crossing.ml new file mode 100644 index 000000000000..352dc723f420 --- /dev/null +++ b/testsuite/tests/typing-local/crossing.ml @@ -0,0 +1,346 @@ +(* TEST + * expect *) + +type ('a, 'b) bar0 = Bar0 of 'a * 'b +type bar = (int, string) bar0 + +type ('a, 'b) foo0 = { + x : 'a; + y : 'b; +} +type foo = (int, string) foo0 +[%%expect{| +type ('a, 'b) bar0 = Bar0 of 'a * 'b +type bar = (int, string) bar0 +type ('a, 'b) foo0 = { x : 'a; y : 'b; } +type foo = (int, string) foo0 +|}] + +(* mode crosing is implemented at several points + in the type checker corresponding to the + following tests *) + +(* We are very stingy in the following when giving + type annotation because we want to control type + information precisely, so that the examples behave + in expected way only for supposed reasons. *) + +(* A single modification of `type_argument` + enables mode crossing at the following points, + all depending on the expected type *) + +(* 1. function argument crosses mode at application *) +let f' x = x + 1 +[%%expect{| +val f' : int -> int = +|}] + +let f : local_ _ -> _ = + fun n -> f' n +[%%expect{| +val f : local_ int -> int = +|}] + +(* As comparison, string won't cross modes *) +let f' x = x ^ "hello" +[%%expect{| +val f' : string -> string = +|}] + +let f : local_ _ -> _ = + fun x -> f' x +[%%expect{| +Line 2, characters 14-15: +2 | fun x -> f' x + ^ +Error: This value escapes its region +|}] + +(* 2. constructor argument crosses mode at construction *) +let f : local_ _ -> bar = + fun n -> Bar0 (n, "hello") +[%%expect{| +val f : local_ int -> bar = +|}] + +let f : local_ _ -> bar = + fun n -> Bar0 (42, n) +[%%expect{| +Line 2, characters 21-22: +2 | fun n -> Bar0 (42, n) + ^ +Error: This value escapes its region +|}] + +(* 3. record field crosses mode at construction *) +let f : local_ _ -> foo = + fun n -> {x = n; y = "hello"} +[%%expect{| +val f : local_ int -> foo = +|}] + +let f : local_ _ -> foo = + fun n -> {x = 42; y = n} +[%%expect{| +Line 2, characters 24-25: +2 | fun n -> {x = 42; y = n} + ^ +Error: This value escapes its region +|}] + +(* 4. expression crosses mode when being constrained *) +let f : local_ _ -> _ = + fun n -> (n : int) +[%%expect{| +val f : local_ int -> int = +|}] + +let f : local_ _ -> _ = + fun n -> (n : string) +[%%expect{| +Line 2, characters 12-13: +2 | fun n -> (n : string) + ^ +Error: This value escapes its region +|}] + +(* 5. polymorphic variant arguments crosses mode on construction*) +let f : local_ _ -> [> `Number of int] = + fun n -> `Number n +[%%expect{| +val f : local_ int -> [> `Number of int ] = +|}] + +let f : local_ _ -> [> `Text of string] = + fun n -> `Text n +[%%expect{| +Line 2, characters 17-18: +2 | fun n -> `Text n + ^ +Error: This value escapes its region +|}] + +(* tuple elements crosses mode at construction *) +let f : local_ _ -> int * int = + fun n -> (n, n) +[%%expect{| +val f : local_ int -> int * int = +|}] + +let f : local_ _ -> string * string = + fun n -> (n, n) +[%%expect{| +Line 2, characters 12-13: +2 | fun n -> (n, n) + ^ +Error: This value escapes its region +|}] + +(* array elements crosses mode at construction *) +let f : local_ _ -> int array = + fun n -> [|n; n|] +[%%expect{| +val f : local_ int -> int array = +|}] + +let f: local_ _ -> string array = + fun n -> [|n; n|] +[%%expect{| +Line 2, characters 13-14: +2 | fun n -> [|n; n|] + ^ +Error: This value escapes its region +|}] + +(* after discussion with sdolan, we agree that + the following cannot type check because of lock; + lazy is not commonly used anyway. *) +let f: local_ _ -> int lazy_t = + fun n -> lazy n +[%%expect{| +Line 2, characters 16-17: +2 | fun n -> lazy n + ^ +Error: The value n is local, so cannot be used inside a closure that might escape +|}] + +(* record field crosses mode at projection *) +let f : local_ foo -> _ = + fun r -> r.x +[%%expect{| +val f : local_ foo -> int = +|}] + +let f : local_ foo -> _ = + fun r -> r.y +[%%expect{| +Line 2, characters 11-14: +2 | fun r -> r.y + ^^^ +Error: This value escapes its region +|}] + +(* the expected type is not considered when mode crossing the result of +pexp_field. However, upon function definition, the expected type of +the body will be used to mode cross *) +let f : local_ _ -> int = + fun r -> r.x +[%%expect{| +val f : local_ (int, 'a) foo0 -> int = +|}] + +(* expression crosses mode when prefixed with local_ *) +let g : int -> int + = fun x -> x + 42 + +let f : _ -> int = + fun () -> + g (local_ 42) +[%%expect{| +val g : int -> int = +val f : unit -> int = +|}] + +let g : string -> string + = fun y -> y ^ "hello" + +let f : _ -> string = + fun () -> + g (local_ "world") + +[%%expect{| +val g : string -> string = +Line 6, characters 6-22: +6 | g (local_ "world") + ^^^^^^^^^^^^^^^^ +Error: This value escapes its region +|}] + +(* the result of function application crosses mode *) +let f : _ -> local_ _ = + fun () -> local_ 42 +[%%expect{| +val f : unit -> local_ int = +|}] + +let g : _ -> _ = + fun () -> f () +[%%expect{| +val g : unit -> int = +|}] + +let f : _ -> local_ _ = + fun () -> local_ "hello" +[%%expect{| +val f : unit -> local_ string = +|}] + +let g : _ -> _ = + fun () -> f () +[%%expect{| +Line 2, characters 12-16: +2 | fun () -> f () + ^^^^ +Error: This value escapes its region +|}] + +(* constructor argument crosses modes upon pattern matching *) +let f : local_ bar -> _ = + fun b -> + match b with + | Bar0 (x, _) -> x +[%%expect{| +val f : local_ bar -> int = +|}] + +(* This example is identical to the last one, + except the type annotation. *) +(* This example works because function body + crosses modes based on its expected type *) +let f : local_ _ -> int = + fun b -> + match b with + | Bar0 (x, _) -> x +[%%expect{| +val f : local_ (int, 'a) bar0 -> int = +|}] + +let f : local_ bar -> _ = + fun b -> + match b with + | Bar0 (_, y) -> y +[%%expect{| +Line 4, characters 21-22: +4 | | Bar0 (_, y) -> y + ^ +Error: This value escapes its region +|}] + +(* record fields crosses modes upon pattern matching *) +let f : local_ foo -> _ = + fun r -> + match r with + | {x; _} -> x +[%%expect{| +val f : local_ foo -> int = +|}] + +(* this example works again because function body crosses modes + based on its expected type *) +let f : local_ _ -> int = + fun r -> + match r with + | {x; _} -> x +[%%expect{| +val f : local_ (int, 'a) foo0 -> int = +|}] + +let f : local_ foo -> _ = + fun r -> + match r with + | {y; _} -> y +[%%expect{| +Line 4, characters 16-17: +4 | | {y; _} -> y + ^ +Error: This value escapes its region +|}] + +(* constraint crosses modes upon pattern matching *) +let f : local_ _ -> _ = + fun (x : int) -> x +[%%expect{| +val f : local_ int -> int = +|}] + +let f : local_ _ -> _ = + fun (x : string) -> x +[%%expect{| +Line 2, characters 22-23: +2 | fun (x : string) -> x + ^ +Error: This value escapes its region +|}] + + +(* Following tests immediacy detection, + given by goldfirere *) +module M : sig + type t [@@immediate] +end = struct + type t = int +end + +type t2 = { x : int } [@@unboxed] + +let f : local_ _ -> M.t = + fun x -> x + +let f : local_ _ -> t2 = + fun x -> x +[%%expect{| +module M : sig type t [@@immediate] end +type t2 = { x : int; } [@@unboxed] +val f : local_ M.t -> M.t = +val f : local_ t2 -> t2 = +|}] diff --git a/testsuite/tests/typing-local/local.ml b/testsuite/tests/typing-local/local.ml index 0a1b6f10d580..7c1564db6a60 100644 --- a/testsuite/tests/typing-local/local.ml +++ b/testsuite/tests/typing-local/local.ml @@ -1904,23 +1904,18 @@ val primloc : int32 -> int = |}] (* (&&) and (||) tail call on the right *) -let testbool1 x = - let local_ b = not x in - (b || false) && true - -let testbool2 x = - let local_ b = not x in - true && (false || b) -[%%expect{| -val testbool1 : bool -> bool = -Line 7, characters 20-21: -7 | true && (false || b) - ^ +let testbool1 f = let local_ r = ref 42 in (f r || false) && true + +let testbool2 f = let local_ r = ref 42 in true && (false || f r) +[%%expect{| +val testbool1 : (local_ int ref -> bool) -> bool = +Line 3, characters 63-64: +3 | let testbool2 f = let local_ r = ref 42 in true && (false || f r) + ^ Error: This local value escapes its region - Hint: Cannot return local value without an explicit "local_" annotation + Hint: This argument cannot be local, because this is a tail call |}] - (* mode-crossing using unary + *) let promote (local_ x) = +x [%%expect{| diff --git a/typing/typecore.ml b/typing/typecore.ml index e95372b2cb0f..cd0d95680f62 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -545,6 +545,22 @@ let has_local_attr_pat ppat = let has_local_attr_exp pexp = has_local_attr pexp.pexp_loc pexp.pexp_attributes +let mode_cross env (ty : type_expr) mode = + if is_principal ty then begin + match immediacy env ty with + | Type_immediacy.Always -> Value_mode.newvar () + | Type_immediacy.Always_on_64bits when !Clflags.native_code && Sys.word_size = 64 -> + Value_mode.newvar () (* floating and relaxed *) + | _ -> mode + end + else mode + +let expect_mode_cross env (ty : type_expr) (mode : expected_mode) = + {mode with mode = mode_cross env ty mode.mode} + +let expect_pat_mode_cross env (ty : type_expr) (mode : expected_pat_mode) = + {mode with mode = mode_cross env ty mode.mode} + (* Typing of patterns *) (* unification inside type_exp and type_expect *) @@ -1957,7 +1973,7 @@ and type_pat_aux end | Ppat_var name -> let ty = instance expected_ty in - let alloc_mode = alloc_mode in + let alloc_mode = expect_pat_mode_cross !env expected_ty alloc_mode in let id = (* PR#7330 *) if name.txt = "*extension*" then Ident.create_local name.txt @@ -2020,6 +2036,7 @@ and type_pat_aux assert construction_not_used_in_counterexamples; type_pat Value sq expected_ty (fun q -> let ty_var, mode = solve_Ppat_alias ~refine env q in + let mode = mode_cross !env expected_ty mode in let id = enter_variable ~is_as_variable:true loc name mode ty_var sp.ppat_attributes @@ -2366,7 +2383,7 @@ and type_pat_aux in let cty, ty, expected_ty' = solve_Ppat_constraint ~refine loc env type_mode sty expected_ty in - type_pat category sp' expected_ty' (fun p -> + type_pat ~alloc_mode category sp' expected_ty' (fun p -> (*Format.printf "%a@.%a@." Printtyp.raw_type_expr ty Printtyp.raw_type_expr p.pat_type;*) @@ -2713,7 +2730,7 @@ let remaining_function_type ty_ret mode_ret rev_args = in ty_ret -let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs = +let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar = let labels_match ~param ~arg = param = arg || !Clflags.classic && arg = Nolabel && not (is_optional param) @@ -2732,7 +2749,7 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs = | Tvar _ -> let ty_arg = newvar () in let ty_res = newvar () in - if get_level ty_fun >= get_level ty_arg && + if ret_tvar && not (is_prim ~name:"%identity" funct) && not (is_prim ~name:"%obj_magic" funct) then @@ -2766,7 +2783,7 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs = in loop ty_fun mode_fun rev_args sargs -let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs = +let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret_tvar = let warned = ref false in let rec loop ty_fun ty_fun0 mode_fun rev_args sargs = let ty_fun' = expand_head env ty_fun in @@ -2847,7 +2864,7 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs = | _ -> (* We're not looking at a *known* function type anymore, or there are no arguments left. *) - collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs + collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs ret_tvar in loop ty_fun ty_fun0 mode_fun [] sargs @@ -3740,18 +3757,20 @@ and type_expect_ [Nolabel, sbody]) -> if not (Clflags.Extension.is_enabled Local) then raise (Typetexp.Error (loc, Env.empty, Local_not_enabled)); - submode ~loc ~env Value_mode.local expected_mode; + let mode = expect_mode_cross env ty_expected mode_local in + submode ~loc ~env mode.mode expected_mode; let exp = - type_expect ?in_function ~recarg env mode_local sbody + type_expect ?in_function ~recarg env mode sbody ty_expected_explained in { exp with exp_loc = loc } | Pexp_apply ({ pexp_desc = Pexp_extension({txt = ("ocaml.local" | "local")}, PStr []) }, [Nolabel, sbody]) -> - submode ~loc ~env Value_mode.local expected_mode; + let mode = expect_mode_cross env ty_expected mode_local in + submode ~loc ~env mode.mode expected_mode; let exp = - type_expect ?in_function ~recarg env mode_local sbody + type_expect ?in_function ~recarg env mode sbody ty_expected_explained in { exp with exp_loc = loc } @@ -3775,15 +3794,24 @@ and type_expect_ let mode = Value_mode.newvar () in mode, mode_nontail mode in - let rec lower_args seen ty_fun = + (* does the function return a tvar which is too generic? *) + let rec ret_tvar seen ty_fun = let ty = expand_head env ty_fun in - if TypeSet.mem ty seen then () else + if TypeSet.mem ty seen then false else match get_desc ty with Tarrow (_l, ty_arg, ty_fun, _com) -> (try unify_var env (newvar()) ty_arg with Unify _ -> assert false); - lower_args (TypeSet.add ty seen) ty_fun - | _ -> () + ret_tvar (TypeSet.add ty seen) ty_fun + | Tvar _ -> + let v = newvar () in + let rt = get_level ty > get_level v in + unify_var env v ty; + rt + | _ -> + let v = newvar () in + unify_var env v ty; + false in let type_sfunct sfunct = begin_def (); (* one more level for non-returning functions *) @@ -3795,8 +3823,8 @@ and type_expect_ end; let ty = instance funct.exp_type in end_def (); - wrap_trace_gadt_instances env (lower_args TypeSet.empty) ty; - funct + let rt = wrap_trace_gadt_instances env (ret_tvar TypeSet.empty) ty in + rt, funct in let type_sfunct_args sfunct extra_args = match sfunct.pexp_desc with @@ -3805,8 +3833,8 @@ and type_expect_ | _ -> type_sfunct sfunct, extra_args in - let funct, sargs = - let funct = type_sfunct sfunct in + let (rt, funct), sargs = + let rt, funct = type_sfunct sfunct in match funct.exp_desc, sargs with | Texp_ident (_, _, {val_kind = Val_prim {prim_name = "%revapply"}; val_type}, Id_prim _), @@ -3820,14 +3848,12 @@ and type_expect_ when check_apply_prim_type Apply val_type -> type_sfunct_args actual_sfunct [Nolabel, sarg] | _ -> - funct, sargs + (rt, funct), sargs in - begin_def (); let (args, ty_res, position) = - type_application env loc expected_mode position funct funct_mode sargs + type_application env loc expected_mode position funct funct_mode sargs rt in - end_def (); - unify_var env (newvar()) funct.exp_type; + rue { exp_desc = Texp_apply(funct, args, position); exp_loc = loc; exp_extra = []; @@ -3897,7 +3923,7 @@ and type_expect_ let expl = List.map2 (fun body (ty, argument_mode) -> - type_expect env (mode_nontail argument_mode) + type_expect env (mode_nontail (mode_cross env ty argument_mode)) body (mk_expected ty)) sexpl types_and_modes in @@ -4119,10 +4145,25 @@ and type_expect_ | Nonlocal -> Value_mode.local_to_regional rmode | Unrestricted -> rmode in - submode ~loc ~env mode expected_mode; + + if !Clflags.principal then + begin_def (); + + (* ty_arg is the type of field *) + (* ty_res is the type of record *) + (* they could share type variables *) + (* which are now instantiated *) let (_, ty_arg, ty_res) = instance_label false label in + + (* we now link the two record types *) unify_exp env record ty_res; - rue { + + if !Clflags.principal then begin + end_def (); + generalize_structure ty_arg + end; + let mode = mode_cross env ty_arg mode in + ruem ~mode ~expected_mode { exp_desc = Texp_field(record, lid, label); exp_loc = loc; exp_extra = []; exp_type = ty_arg; @@ -4153,7 +4194,7 @@ and type_expect_ let to_unify = Predef.type_array ty in with_explanation (fun () -> unify_exp_types loc env to_unify (generic_instance ty_expected)); - let argument_mode = mode_global in + let argument_mode = expect_mode_cross env ty mode_global in let argl = List.map (fun sarg -> type_expect env argument_mode sarg (mk_expected ty)) @@ -5097,6 +5138,8 @@ and type_function ?in_function in let cases_expected_mode, curry = if uncurried_function then + (* no need to check mode crossing in this case*) + (* because ty_res always a function *) mode_nontail (Value_mode.of_alloc ret_mode), More_args { partial_mode = ret_mode } else begin @@ -5104,7 +5147,8 @@ and type_function ?in_function let ret_value_mode = if region_locked then Value_mode.local_to_regional ret_value_mode else ret_value_mode - in + in + let ret_value_mode = mode_cross env ty_res ret_value_mode in mode_return ret_value_mode, Final_arg { partial_mode = Alloc_mode.join [arg_mode; alloc_mode] } end @@ -5646,6 +5690,7 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg end end | None -> + let mode = expect_mode_cross env ty_expected' mode in let texp = type_expect ?recarg env mode sarg (mk_expected ?explanation ty_expected') in unify_exp env texp ty_expected; @@ -5684,7 +5729,7 @@ and type_apply_arg env ~funct ~index ~position ~partial_app (lbl, arg) = (lbl, Arg arg) | Omitted _ as arg -> (lbl, arg) -and type_application env app_loc expected_mode position funct funct_mode sargs = +and type_application env app_loc expected_mode position funct funct_mode sargs ret_tvar = let is_ignore funct = is_prim ~name:"%ignore" funct && (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true @@ -5693,11 +5738,17 @@ and type_application env app_loc expected_mode position funct funct_mode sargs = match sargs with | (* Special case for ignore: avoid discarding warning *) [Nolabel, sarg] when is_ignore funct -> + if !Clflags.principal then begin_def () ; let marg, ty_arg, mres, ty_res = filter_arrow env (instance funct.exp_type) Nolabel in + if !Clflags.principal then begin + end_def (); + generalize_structure ty_res + end; + let mode = mode_cross env ty_res (Value_mode.of_alloc mres) in submode ~loc:app_loc ~env - (Value_mode.of_alloc mres) expected_mode; + mode expected_mode; let marg = mode_argument ~funct ~index:0 ~position ~partial_app:false marg in @@ -5723,9 +5774,10 @@ and type_application env app_loc expected_mode position funct funct_mode sargs = true) end in + if !Clflags.principal then begin_def () ; let ty_ret, mode_ret, args = collect_apply_args env funct ignore_labels ty (instance ty) - (Value_mode.regional_to_local_alloc funct_mode) sargs + (Value_mode.regional_to_local_alloc funct_mode) sargs ret_tvar in let partial_app = is_partial_apply args in let position = if partial_app then Default else position in @@ -5738,8 +5790,12 @@ and type_application env app_loc expected_mode position funct funct_mode sargs = type_omitted_parameters expected_mode env ty_ret mode_ret args in - submode ~loc:app_loc ~env - (Value_mode.of_alloc mode_ret) expected_mode; + if !Clflags.principal then begin + end_def () ; + generalize_structure ty_ret + end; + let mode = mode_cross env ty_ret (Value_mode.of_alloc mode_ret) in + submode ~loc:app_loc ~env mode expected_mode; args, ty_ret, position and type_construct env (expected_mode : expected_mode) loc lid sarg