Introduce warning 68 to warn about hidden allocation due to pattern match of mutable field in curried functions (#9751)
Introduce new warning 68master
parent
d9a3ad413f
commit
49aa87c316
4
Changes
4
Changes
|
@ -270,6 +270,10 @@ Working version
|
||||||
(Nicolás Ojeda Bär, review by Gabriel Scherer, Florian Angeletti and Leo
|
(Nicolás Ojeda Bär, review by Gabriel Scherer, Florian Angeletti and Leo
|
||||||
White)
|
White)
|
||||||
|
|
||||||
|
- #9751: Add warning 68. Pattern-matching depending on mutable state
|
||||||
|
prevents the remaining arguments from being uncurried.
|
||||||
|
(Hugo Heuzard, review by Leo White)
|
||||||
|
|
||||||
### Internal/compiler-libs changes:
|
### Internal/compiler-libs changes:
|
||||||
|
|
||||||
- #9216: add Lambda.duplicate which refreshes bound identifiers
|
- #9216: add Lambda.duplicate which refreshes bound identifiers
|
||||||
|
|
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -181,7 +181,7 @@ let new_checkpoint_list checkpoint_count accepted rejected =
|
||||||
let (k, l) =
|
let (k, l) =
|
||||||
list_truncate2 (checkpoint_count - List.length accepted) rejected
|
list_truncate2 (checkpoint_count - List.length accepted) rejected
|
||||||
in
|
in
|
||||||
(List.merge (fun {c_time = t1} {c_time = t2} -> compare t2 t1) accepted k,
|
(List.merge (fun t1 t2 -> compare t2.c_time t1.c_time) accepted k,
|
||||||
l)
|
l)
|
||||||
|
|
||||||
(* Clean the checkpoint list. *)
|
(* Clean the checkpoint list. *)
|
||||||
|
|
|
@ -733,25 +733,53 @@ and transl_apply ~scopes
|
||||||
sargs)
|
sargs)
|
||||||
: Lambda.lambda)
|
: Lambda.lambda)
|
||||||
|
|
||||||
and transl_function0
|
and transl_curried_function
|
||||||
~scopes loc return untuplify_fn max_arity
|
~scopes loc return
|
||||||
|
repr partial (param:Ident.t) cases =
|
||||||
|
let max_arity = Lambda.max_arity () in
|
||||||
|
let rec loop ~scopes loc return ~arity partial (param:Ident.t) cases =
|
||||||
|
match cases with
|
||||||
|
[{c_lhs=pat; c_guard=None;
|
||||||
|
c_rhs={exp_desc =
|
||||||
|
Texp_function
|
||||||
|
{ arg_label = _; param = param'; cases = cases';
|
||||||
|
partial = partial'; }; exp_env; exp_type;exp_loc}}]
|
||||||
|
when arity < max_arity ->
|
||||||
|
if Parmatch.inactive ~partial pat
|
||||||
|
then
|
||||||
|
let kind = value_kind pat.pat_env pat.pat_type in
|
||||||
|
let return_kind = function_return_value_kind exp_env exp_type in
|
||||||
|
let ((_, params, return), body) =
|
||||||
|
loop ~scopes exp_loc return_kind ~arity:(arity + 1)
|
||||||
|
partial' param' cases'
|
||||||
|
in
|
||||||
|
((Curried, (param, kind) :: params, return),
|
||||||
|
Matching.for_function ~scopes loc None (Lvar param)
|
||||||
|
[pat, body] partial)
|
||||||
|
else begin
|
||||||
|
begin match partial with
|
||||||
|
| Total ->
|
||||||
|
Location.prerr_warning pat.pat_loc
|
||||||
|
Match_on_mutable_state_prevent_uncurry
|
||||||
|
| Partial -> ()
|
||||||
|
end;
|
||||||
|
transl_tupled_function ~scopes ~arity
|
||||||
|
loc return repr partial param cases
|
||||||
|
end
|
||||||
|
| cases ->
|
||||||
|
transl_tupled_function ~scopes ~arity
|
||||||
|
loc return repr partial param cases
|
||||||
|
in
|
||||||
|
loop ~scopes loc return ~arity:1 partial param cases
|
||||||
|
|
||||||
|
and transl_tupled_function
|
||||||
|
~scopes ~arity loc return
|
||||||
repr partial (param:Ident.t) cases =
|
repr partial (param:Ident.t) cases =
|
||||||
match cases with
|
match cases with
|
||||||
[{c_lhs=pat; c_guard=None;
|
|
||||||
c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases;
|
|
||||||
partial = partial'; }; exp_env; exp_type} as exp}]
|
|
||||||
when max_arity > 1 && Parmatch.inactive ~partial pat ->
|
|
||||||
let kind = value_kind pat.pat_env pat.pat_type in
|
|
||||||
let return_kind = function_return_value_kind exp_env exp_type in
|
|
||||||
let ((_, params, return), body) =
|
|
||||||
transl_function0 ~scopes exp.exp_loc return_kind false (max_arity - 1)
|
|
||||||
repr partial' param' cases
|
|
||||||
in
|
|
||||||
((Curried, (param, kind) :: params, return),
|
|
||||||
Matching.for_function ~scopes loc None (Lvar param)
|
|
||||||
[pat, body] partial)
|
|
||||||
| {c_lhs={pat_desc = Tpat_tuple pl}} :: _
|
| {c_lhs={pat_desc = Tpat_tuple pl}} :: _
|
||||||
when untuplify_fn && List.length pl <= max_arity ->
|
when !Clflags.native_code
|
||||||
|
&& arity = 1
|
||||||
|
&& List.length pl <= (Lambda.max_arity ()) ->
|
||||||
begin try
|
begin try
|
||||||
let size = List.length pl in
|
let size = List.length pl in
|
||||||
let pats_expr_list =
|
let pats_expr_list =
|
||||||
|
@ -783,28 +811,30 @@ and transl_function0
|
||||||
((Tupled, tparams, return),
|
((Tupled, tparams, return),
|
||||||
Matching.for_tupled_function ~scopes loc params
|
Matching.for_tupled_function ~scopes loc params
|
||||||
(transl_tupled_cases ~scopes pats_expr_list) partial)
|
(transl_tupled_cases ~scopes pats_expr_list) partial)
|
||||||
with Matching.Cannot_flatten ->
|
with Matching.Cannot_flatten ->
|
||||||
((Curried, [param, Pgenval], return),
|
transl_function0 ~scopes loc return repr partial param cases
|
||||||
Matching.for_function ~scopes loc repr (Lvar param)
|
|
||||||
(transl_cases ~scopes cases) partial)
|
|
||||||
end
|
end
|
||||||
| {c_lhs=pat} :: other_cases ->
|
| _ -> transl_function0 ~scopes loc return repr partial param cases
|
||||||
let kind =
|
|
||||||
|
and transl_function0
|
||||||
|
~scopes loc return
|
||||||
|
repr partial (param:Ident.t) cases =
|
||||||
|
let kind =
|
||||||
|
match cases with
|
||||||
|
| [] ->
|
||||||
|
(* With Camlp4, a pattern matching might be empty *)
|
||||||
|
Pgenval
|
||||||
|
| {c_lhs=pat} :: other_cases ->
|
||||||
(* All the patterns might not share the same types. We must take the
|
(* All the patterns might not share the same types. We must take the
|
||||||
union of the patterns types *)
|
union of the patterns types *)
|
||||||
List.fold_left (fun k {c_lhs=pat} ->
|
List.fold_left (fun k {c_lhs=pat} ->
|
||||||
Typeopt.value_kind_union k
|
Typeopt.value_kind_union k
|
||||||
(value_kind pat.pat_env pat.pat_type))
|
(value_kind pat.pat_env pat.pat_type))
|
||||||
(value_kind pat.pat_env pat.pat_type) other_cases
|
(value_kind pat.pat_env pat.pat_type) other_cases
|
||||||
in
|
in
|
||||||
((Curried, [param, kind], return),
|
((Curried, [param, kind], return),
|
||||||
Matching.for_function ~scopes loc repr (Lvar param)
|
Matching.for_function ~scopes loc repr (Lvar param)
|
||||||
(transl_cases ~scopes cases) partial)
|
(transl_cases ~scopes cases) partial)
|
||||||
| [] ->
|
|
||||||
(* With Camlp4, a pattern matching might be empty *)
|
|
||||||
((Curried, [param, Pgenval], return),
|
|
||||||
Matching.for_function ~scopes loc repr (Lvar param)
|
|
||||||
(transl_cases ~scopes cases) partial)
|
|
||||||
|
|
||||||
and transl_function ~scopes e param cases partial =
|
and transl_function ~scopes e param cases partial =
|
||||||
let ((kind, params, return), body) =
|
let ((kind, params, return), body) =
|
||||||
|
@ -812,8 +842,7 @@ and transl_function ~scopes e param cases partial =
|
||||||
(function repr ->
|
(function repr ->
|
||||||
let pl = push_defaults e.exp_loc [] cases partial in
|
let pl = push_defaults e.exp_loc [] cases partial in
|
||||||
let return_kind = function_return_value_kind e.exp_env e.exp_type in
|
let return_kind = function_return_value_kind e.exp_env e.exp_type in
|
||||||
transl_function0 ~scopes e.exp_loc return_kind
|
transl_curried_function ~scopes e.exp_loc return_kind
|
||||||
!Clflags.native_code (Lambda.max_arity())
|
|
||||||
repr partial param pl)
|
repr partial param pl)
|
||||||
in
|
in
|
||||||
let attr = default_function_attribute in
|
let attr = default_function_attribute in
|
||||||
|
@ -1107,8 +1136,7 @@ and transl_letop ~scopes loc env let_ ands param case partial =
|
||||||
let (kind, params, return), body =
|
let (kind, params, return), body =
|
||||||
event_function ~scopes case.c_rhs
|
event_function ~scopes case.c_rhs
|
||||||
(function repr ->
|
(function repr ->
|
||||||
transl_function0 ~scopes case.c_rhs.exp_loc return_kind
|
transl_curried_function ~scopes case.c_rhs.exp_loc return_kind
|
||||||
!Clflags.native_code (Lambda.max_arity())
|
|
||||||
repr partial param [case])
|
repr partial param [case])
|
||||||
in
|
in
|
||||||
let attr = default_function_attribute in
|
let attr = default_function_attribute in
|
||||||
|
|
|
@ -960,6 +960,10 @@ mutually recursive types.
|
||||||
67
|
67
|
||||||
\ \ Unused functor parameter.
|
\ \ Unused functor parameter.
|
||||||
|
|
||||||
|
68
|
||||||
|
\ \ Pattern-matching depending on mutable state prevents the remaining
|
||||||
|
arguments from being uncurried.
|
||||||
|
|
||||||
The letters stand for the following sets of warnings. Any letter not
|
The letters stand for the following sets of warnings. Any letter not
|
||||||
mentioned here corresponds to the empty set.
|
mentioned here corresponds to the empty set.
|
||||||
|
|
||||||
|
@ -1013,7 +1017,7 @@ mentioned here corresponds to the empty set.
|
||||||
|
|
||||||
.IP
|
.IP
|
||||||
The default setting is
|
The default setting is
|
||||||
.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-30\-32..42\-44\-45\-48\-50\-60\-66 .
|
.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-30\-32..42\-44\-45\-48\-50\-60\-66\-67\-68 .
|
||||||
Note that warnings
|
Note that warnings
|
||||||
.BR 5 \ and \ 10
|
.BR 5 \ and \ 10
|
||||||
are not always triggered, depending on the internals of the type checker.
|
are not always triggered, depending on the internals of the type checker.
|
||||||
|
|
|
@ -0,0 +1,11 @@
|
||||||
|
File "w68.ml", line 34, characters 33-43:
|
||||||
|
34 | let dont_warn_with_partial_match None x = x
|
||||||
|
^^^^^^^^^^
|
||||||
|
Warning 8 [partial-match]: this pattern-matching is not exhaustive.
|
||||||
|
Here is an example of a case that is not matched:
|
||||||
|
Some _
|
||||||
|
File "w68.ml", line 14, characters 10-13:
|
||||||
|
14 | let alloc {a} b = a + b
|
||||||
|
^^^
|
||||||
|
Warning 68 [match-on-mutable-state-prevent-uncurry]: This pattern depends on mutable state.
|
||||||
|
It prevents the remaining arguments from being uncurried, which will cause additional closure allocations.
|
|
@ -0,0 +1,34 @@
|
||||||
|
(* TEST
|
||||||
|
|
||||||
|
flags = "-w A"
|
||||||
|
|
||||||
|
* setup-ocamlopt.byte-build-env
|
||||||
|
** ocamlopt.byte
|
||||||
|
*** check-ocamlopt.byte-output
|
||||||
|
**** run
|
||||||
|
***** check-program-output
|
||||||
|
*)
|
||||||
|
|
||||||
|
type a = { mutable a : int }
|
||||||
|
|
||||||
|
let alloc {a} b = a + b
|
||||||
|
|
||||||
|
let noalloc b {a} = b + a
|
||||||
|
|
||||||
|
let measure name f =
|
||||||
|
let a = {a = 1} in
|
||||||
|
let b = 2 in
|
||||||
|
let before = Gc.minor_words () in
|
||||||
|
let (_ : int) = f ~a ~b in
|
||||||
|
let after = Gc.minor_words () in
|
||||||
|
let alloc = int_of_float (after -. before) in
|
||||||
|
match alloc with
|
||||||
|
| 0 -> Printf.printf "%S doesn't allocate\n" name
|
||||||
|
| _ -> Printf.printf "%S allocates\n" name
|
||||||
|
|
||||||
|
let () =
|
||||||
|
measure "noalloc" (fun ~a ~b -> noalloc b a);
|
||||||
|
measure "alloc" (fun ~a ~b -> alloc a b)
|
||||||
|
|
||||||
|
|
||||||
|
let dont_warn_with_partial_match None x = x
|
|
@ -0,0 +1,2 @@
|
||||||
|
"noalloc" doesn't allocate
|
||||||
|
"alloc" allocates
|
|
@ -92,6 +92,7 @@ type t =
|
||||||
| Redefining_unit of string (* 65 *)
|
| Redefining_unit of string (* 65 *)
|
||||||
| Unused_open_bang of string (* 66 *)
|
| Unused_open_bang of string (* 66 *)
|
||||||
| Unused_functor_parameter of string (* 67 *)
|
| Unused_functor_parameter of string (* 67 *)
|
||||||
|
| Match_on_mutable_state_prevent_uncurry (* 68 *)
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(* If you remove a warning, leave a hole in the numbering. NEVER change
|
(* If you remove a warning, leave a hole in the numbering. NEVER change
|
||||||
|
@ -169,9 +170,10 @@ let number = function
|
||||||
| Redefining_unit _ -> 65
|
| Redefining_unit _ -> 65
|
||||||
| Unused_open_bang _ -> 66
|
| Unused_open_bang _ -> 66
|
||||||
| Unused_functor_parameter _ -> 67
|
| Unused_functor_parameter _ -> 67
|
||||||
|
| Match_on_mutable_state_prevent_uncurry -> 68
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let last_warning_number = 67
|
let last_warning_number = 68
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(* Third component of each tuple is the list of names for each warning. The
|
(* Third component of each tuple is the list of names for each warning. The
|
||||||
|
@ -327,6 +329,9 @@ let descriptions =
|
||||||
["unused-open-bang"];
|
["unused-open-bang"];
|
||||||
67, "Unused functor parameter.",
|
67, "Unused functor parameter.",
|
||||||
["unused-functor-parameter"];
|
["unused-functor-parameter"];
|
||||||
|
68, "Pattern-matching depending on mutable state prevents the remaining \
|
||||||
|
arguments from being uncurried.",
|
||||||
|
["match-on-mutable-state-prevent-uncurry"];
|
||||||
]
|
]
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
@ -567,7 +572,7 @@ let parse_options errflag s =
|
||||||
current := {(!current) with error; active}
|
current := {(!current) with error; active}
|
||||||
|
|
||||||
(* If you change these, don't forget to change them in man/ocamlc.m *)
|
(* If you change these, don't forget to change them in man/ocamlc.m *)
|
||||||
let defaults_w = "+a-4-6-7-9-27-29-30-32..42-44-45-48-50-60-66-67";;
|
let defaults_w = "+a-4-6-7-9-27-29-30-32..42-44-45-48-50-60-66-67-68";;
|
||||||
let defaults_warn_error = "-a+31";;
|
let defaults_warn_error = "-a+31";;
|
||||||
|
|
||||||
let () = parse_options false defaults_w;;
|
let () = parse_options false defaults_w;;
|
||||||
|
@ -805,6 +810,10 @@ let message = function
|
||||||
which shadows the existing one.\n\
|
which shadows the existing one.\n\
|
||||||
Hint: Did you mean 'type %s = unit'?" name
|
Hint: Did you mean 'type %s = unit'?" name
|
||||||
| Unused_functor_parameter s -> "unused functor parameter " ^ s ^ "."
|
| Unused_functor_parameter s -> "unused functor parameter " ^ s ^ "."
|
||||||
|
| Match_on_mutable_state_prevent_uncurry ->
|
||||||
|
"This pattern depends on mutable state.\n\
|
||||||
|
It prevents the remaining arguments from being uncurried, which will \
|
||||||
|
cause additional closure allocations."
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let nerrors = ref 0;;
|
let nerrors = ref 0;;
|
||||||
|
|
|
@ -94,6 +94,7 @@ type t =
|
||||||
| Redefining_unit of string (* 65 *)
|
| Redefining_unit of string (* 65 *)
|
||||||
| Unused_open_bang of string (* 66 *)
|
| Unused_open_bang of string (* 66 *)
|
||||||
| Unused_functor_parameter of string (* 67 *)
|
| Unused_functor_parameter of string (* 67 *)
|
||||||
|
| Match_on_mutable_state_prevent_uncurry (* 68 *)
|
||||||
;;
|
;;
|
||||||
|
|
||||||
type alert = {kind:string; message:string; def:loc; use:loc}
|
type alert = {kind:string; message:string; def:loc; use:loc}
|
||||||
|
|
Loading…
Reference in New Issue