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
|
||||
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:
|
||||
|
||||
- #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) =
|
||||
list_truncate2 (checkpoint_count - List.length accepted) rejected
|
||||
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)
|
||||
|
||||
(* Clean the checkpoint list. *)
|
||||
|
|
|
@ -733,25 +733,53 @@ and transl_apply ~scopes
|
|||
sargs)
|
||||
: Lambda.lambda)
|
||||
|
||||
and transl_function0
|
||||
~scopes loc return untuplify_fn max_arity
|
||||
and transl_curried_function
|
||||
~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 =
|
||||
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}} :: _
|
||||
when untuplify_fn && List.length pl <= max_arity ->
|
||||
when !Clflags.native_code
|
||||
&& arity = 1
|
||||
&& List.length pl <= (Lambda.max_arity ()) ->
|
||||
begin try
|
||||
let size = List.length pl in
|
||||
let pats_expr_list =
|
||||
|
@ -783,28 +811,30 @@ and transl_function0
|
|||
((Tupled, tparams, return),
|
||||
Matching.for_tupled_function ~scopes loc params
|
||||
(transl_tupled_cases ~scopes pats_expr_list) partial)
|
||||
with Matching.Cannot_flatten ->
|
||||
((Curried, [param, Pgenval], return),
|
||||
Matching.for_function ~scopes loc repr (Lvar param)
|
||||
(transl_cases ~scopes cases) partial)
|
||||
with Matching.Cannot_flatten ->
|
||||
transl_function0 ~scopes loc return repr partial param cases
|
||||
end
|
||||
| {c_lhs=pat} :: other_cases ->
|
||||
let kind =
|
||||
| _ -> transl_function0 ~scopes loc return repr partial param cases
|
||||
|
||||
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
|
||||
union of the patterns types *)
|
||||
List.fold_left (fun k {c_lhs=pat} ->
|
||||
Typeopt.value_kind_union k
|
||||
(value_kind pat.pat_env pat.pat_type))
|
||||
Typeopt.value_kind_union k
|
||||
(value_kind pat.pat_env pat.pat_type))
|
||||
(value_kind pat.pat_env pat.pat_type) other_cases
|
||||
in
|
||||
((Curried, [param, kind], return),
|
||||
Matching.for_function ~scopes loc repr (Lvar param)
|
||||
(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)
|
||||
in
|
||||
((Curried, [param, kind], return),
|
||||
Matching.for_function ~scopes loc repr (Lvar param)
|
||||
(transl_cases ~scopes cases) partial)
|
||||
|
||||
and transl_function ~scopes e param cases partial =
|
||||
let ((kind, params, return), body) =
|
||||
|
@ -812,8 +842,7 @@ and transl_function ~scopes e param cases partial =
|
|||
(function repr ->
|
||||
let pl = push_defaults e.exp_loc [] cases partial in
|
||||
let return_kind = function_return_value_kind e.exp_env e.exp_type in
|
||||
transl_function0 ~scopes e.exp_loc return_kind
|
||||
!Clflags.native_code (Lambda.max_arity())
|
||||
transl_curried_function ~scopes e.exp_loc return_kind
|
||||
repr partial param pl)
|
||||
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 =
|
||||
event_function ~scopes case.c_rhs
|
||||
(function repr ->
|
||||
transl_function0 ~scopes case.c_rhs.exp_loc return_kind
|
||||
!Clflags.native_code (Lambda.max_arity())
|
||||
transl_curried_function ~scopes case.c_rhs.exp_loc return_kind
|
||||
repr partial param [case])
|
||||
in
|
||||
let attr = default_function_attribute in
|
||||
|
|
|
@ -960,6 +960,10 @@ mutually recursive types.
|
|||
67
|
||||
\ \ 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
|
||||
mentioned here corresponds to the empty set.
|
||||
|
||||
|
@ -1013,7 +1017,7 @@ mentioned here corresponds to the empty set.
|
|||
|
||||
.IP
|
||||
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
|
||||
.BR 5 \ and \ 10
|
||||
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 *)
|
||||
| Unused_open_bang of string (* 66 *)
|
||||
| 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
|
||||
|
@ -169,9 +170,10 @@ let number = function
|
|||
| Redefining_unit _ -> 65
|
||||
| Unused_open_bang _ -> 66
|
||||
| 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
|
||||
|
@ -327,6 +329,9 @@ let descriptions =
|
|||
["unused-open-bang"];
|
||||
67, "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}
|
||||
|
||||
(* 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 () = parse_options false defaults_w;;
|
||||
|
@ -805,6 +810,10 @@ let message = function
|
|||
which shadows the existing one.\n\
|
||||
Hint: Did you mean 'type %s = unit'?" name
|
||||
| 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;;
|
||||
|
|
|
@ -94,6 +94,7 @@ type t =
|
|||
| Redefining_unit of string (* 65 *)
|
||||
| Unused_open_bang of string (* 66 *)
|
||||
| Unused_functor_parameter of string (* 67 *)
|
||||
| Match_on_mutable_state_prevent_uncurry (* 68 *)
|
||||
;;
|
||||
|
||||
type alert = {kind:string; message:string; def:loc; use:loc}
|
||||
|
|
Loading…
Reference in New Issue