Introduce warning 68 to warn about hidden allocation due to pattern match of mutable field in curried functions (#9751)

Introduce new warning 68

11 files changed, 134 insertions, 41 deletions

diff --git a/Changes b/Changes
index 77dee34ba0..659e1e42c0 100644
--- a/Changes
+++ b/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
diff --git a/boot/ocamlc b/boot/ocamlc
index 6bcfb63466..8a1e287b12 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index e353edbc56..9a1af6c673 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml
index 4d3252fb19..83cf23f40e 100644
--- a/debugger/time_travel.ml
+++ b/debugger/time_travel.ml
@@ -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. *)
diff --git a/lambda/translcore.ml b/lambda/translcore.ml
index edf66f255f..c195b7656b 100644
--- a/lambda/translcore.ml
+++ b/lambda/translcore.ml
@@ -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
diff --git a/man/ocamlc.m b/man/ocamlc.m
index 3f2b387d56..b0608d4400 100644
--- a/man/ocamlc.m
+++ b/man/ocamlc.m
@@ -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.
diff --git a/testsuite/tests/warnings/w68.compilers.reference b/testsuite/tests/warnings/w68.compilers.reference
new file mode 100644
index 0000000000..198706c310
--- /dev/null
+++ b/testsuite/tests/warnings/w68.compilers.reference
@@ -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.
diff --git a/testsuite/tests/warnings/w68.ml b/testsuite/tests/warnings/w68.ml
new file mode 100644
index 0000000000..01b9c203ff
--- /dev/null
+++ b/testsuite/tests/warnings/w68.ml
@@ -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
diff --git a/testsuite/tests/warnings/w68.reference b/testsuite/tests/warnings/w68.reference
new file mode 100644
index 0000000000..1e8a8cca45
--- /dev/null
+++ b/testsuite/tests/warnings/w68.reference
@@ -0,0 +1,2 @@
+"noalloc" doesn't allocate
+"alloc" allocates
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 21d29d0bcd..8dd59730fb 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -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;;
diff --git a/utils/warnings.mli b/utils/warnings.mli
index 82e8b613be..0bf8028bfc 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -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}