From 6a892d53631e58abdd922e216d87aba904c64ee5 Mon Sep 17 00:00:00 2001
From: Vincent Laviron <vincent.laviron@gmail.com>
Date: Thu, 14 Sep 2023 12:02:52 +0200
Subject: [PATCH] Add Constant and Class classifications

Use that to assert that Static bindings always have a known size
---
 asmcomp/cmmgen.ml                             | 18 +++++++-
 bytecomp/bytegen.ml                           | 13 +++++-
 lambda/printlambda.ml                         |  2 +
 lambda/translmod.ml                           |  2 +-
 middle_end/flambda/build_export_info.ml       |  2 +-
 middle_end/flambda/flambda.ml                 | 12 +++---
 middle_end/flambda/flambda_invariants.ml      |  4 +-
 middle_end/flambda/flambda_iterators.ml       | 40 +++++++++++++++---
 middle_end/flambda/flambda_to_clambda.ml      |  8 ++--
 middle_end/flambda/flambda_utils.ml           | 26 ++++++++----
 middle_end/flambda/inconstant_idents.ml       |  2 +-
 middle_end/flambda/inline_and_simplify.ml     |  6 +--
 middle_end/flambda/lift_code.ml               | 12 +++---
 .../flambda/lift_let_to_initialize_symbol.ml  |  8 ++--
 middle_end/flambda/ref_to_variables.ml        |  2 +-
 middle_end/flambda/un_anf.ml                  | 16 ++++----
 middle_end/printclambda.ml                    | 10 +++--
 typing/rec_check.ml                           | 41 +++++++++++++++----
 typing/typeclass.ml                           |  2 +-
 typing/typedtree.ml                           |  2 +
 typing/typedtree.mli                          |  2 +
 21 files changed, 161 insertions(+), 69 deletions(-)

diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index c41cfd7efb7..529ebd155ac 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -224,8 +224,22 @@ let rec expr_size env = function
 
 let expr_size_of_binding (clas : Typedtree.recursive_binding_kind) expr =
   match clas with
-  | Not_recursive -> RHS_nonrec
-  | Static -> expr_size V.empty expr
+  | Not_recursive | Constant -> RHS_nonrec
+  | Class ->
+       (* Actual size is always 4, but [transl_class] only generates
+          explicit allocations when the classes are actually recursive.
+          Computing the size means that we don't go through pre-allocation
+          when the classes are not recursive. *)
+      expr_size V.empty expr
+  | Static ->
+      let result = expr_size V.empty expr in
+      (* Patching Closure to properly propagate Constant kinds is too complex;
+         for now, just live with the fact that Static expressions may not always
+         be statcally allocated with Closure.
+         Forthcoming patches will remove all this logic anyway. *)
+      if Config.flambda then
+        assert (result <> RHS_nonrec);
+      result
 
 (* Translate structured constants to Cmm data items *)
 
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 0b4d2ba5f29..cde2efa71a3 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -313,8 +313,17 @@ let rec size_of_lambda env = function
 
 let size_of_rec_binding clas expr =
   match (clas : Typedtree.recursive_binding_kind) with
-  | Not_recursive -> RHS_nonrec
-  | Static -> size_of_lambda Ident.empty expr
+  | Not_recursive | Constant -> RHS_nonrec
+  | Class ->
+       (* Actual size is always 4, but [transl_class] only generates
+          explicit allocations when the classes are actually recursive.
+          Computing the size means that we don't go through pre-allocation
+          when the classes are not recursive. *)
+      size_of_lambda Ident.empty expr
+  | Static ->
+      let result = size_of_lambda Ident.empty expr in
+      assert (result <> RHS_nonrec);
+      result
 
 (**** Merging consecutive events ****)
 
diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml
index d4a3fe75338..455ee8bcaf3 100644
--- a/lambda/printlambda.ml
+++ b/lambda/printlambda.ml
@@ -587,6 +587,8 @@ let rec lam ppf = function
               match rkind with
               | Static -> ""
               | Not_recursive -> "[Nonrec]"
+              | Constant -> "[Cst]"
+              | Class -> "[Class]"
             in
             fprintf ppf "@[<2>%a%s@ %a@]" Ident.print id rec_annot lam def)
           id_arg_list in
diff --git a/lambda/translmod.ml b/lambda/translmod.ml
index 83e8b8cdd6e..cf89886dc34 100644
--- a/lambda/translmod.ml
+++ b/lambda/translmod.ml
@@ -426,7 +426,7 @@ let transl_class_bindings ~scopes cl_list =
    List.map
      (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) ->
        let def = transl_class ~scopes ids id meths cl vf in
-       { id; rkind = Static; def})
+       { id; rkind = Class; def})
      cl_list)
 
 (* Compile one or more functors, merging curried functors to produce
diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml
index 83080d752c7..c4540678a7f 100644
--- a/middle_end/flambda/build_export_info.ml
+++ b/middle_end/flambda/build_export_info.ml
@@ -240,7 +240,7 @@ let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx =
     approx_of_expr env body
   | Let_rec (defs, body) ->
     let env =
-      List.fold_left (fun env (var, _clas, defining_expr) ->
+      List.fold_left (fun env (var, _rkind, defining_expr) ->
           let approx = descr_of_named env defining_expr in
           Env.add_approx env var approx)
         env defs
diff --git a/middle_end/flambda/flambda.ml b/middle_end/flambda/flambda.ml
index b8040a70fc2..299df5f4955 100644
--- a/middle_end/flambda/flambda.ml
+++ b/middle_end/flambda/flambda.ml
@@ -255,15 +255,17 @@ let rec lam ppf (flam : t) =
       let bindings ppf id_arg_list =
         let spc = ref false in
         List.iter
-          (fun (id, clas, l) ->
+          (fun (id, rkind, l) ->
              if !spc then fprintf ppf "@ " else spc := true;
-             let clas_annot =
-               match (clas : Typedtree.recursive_binding_kind) with
+             let rec_annot =
+               match (rkind : Typedtree.recursive_binding_kind) with
                | Static -> ""
                | Not_recursive -> "[Nonrec]"
+               | Constant -> "[Cst]"
+               | Class -> "[Class]"
              in
              fprintf ppf "@[<2>%a%s@ %a@]"
-               Variable.print id clas_annot print_named l)
+               Variable.print id rec_annot print_named l)
           id_arg_list in
       fprintf ppf
         "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
@@ -560,7 +562,7 @@ let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument
         free_variable var;
         aux body
       | Let_rec (bindings, body) ->
-        List.iter (fun (var, _clas, defining_expr) ->
+        List.iter (fun (var, _rkind, defining_expr) ->
             bound_variable var;
             free_variables
               (variables_usage_named ?ignore_uses_in_project_var
diff --git a/middle_end/flambda/flambda_invariants.ml b/middle_end/flambda/flambda_invariants.ml
index 21d54418aa8..cdfc97b53f2 100644
--- a/middle_end/flambda/flambda_invariants.ml
+++ b/middle_end/flambda/flambda_invariants.ml
@@ -162,12 +162,12 @@ let variable_and_symbol_invariants (program : Flambda.program) =
       loop (add_mutable_binding_occurrence env mut_var) body
     | Let_rec (defs, body) ->
       let env =
-        List.fold_left (fun env (var, _clas, def) ->
+        List.fold_left (fun env (var, _rkind, def) ->
             will_traverse_named_expression_later def;
             add_binding_occurrence env var)
           env defs
       in
-      List.iter (fun (var, _clas, def) ->
+      List.iter (fun (var, _rkind, def) ->
         already_added_bound_variable_to_env var;
         loop_named env def) defs;
       loop env body
diff --git a/middle_end/flambda/flambda_iterators.ml b/middle_end/flambda/flambda_iterators.ml
index a892f0cd095..d34a0f8f952 100644
--- a/middle_end/flambda/flambda_iterators.ml
+++ b/middle_end/flambda/flambda_iterators.ml
@@ -74,12 +74,24 @@ let map_snd_sharing f ((a, b) as cpl) =
   else
     (a, new_b)
 
-let map_rec_binding_sharing f ((v, clas, named) as binding) =
+let map_rec_binding_sharing f ((v, rkind, named) as binding) =
   let new_named = f v named in
   if named == new_named then
     binding
   else
-    (v, clas, new_named)
+    let rkind =
+      (* We could be replacing an expression with arbitrary recursive kind
+         by a constant, in which case we need to change the kind.
+         Mode conditions for the [Constant] kind are not stricter
+         than any other kind, so we do not need to re-check the
+         modes. *)
+      match (new_named : Flambda.named) with
+      | Symbol _ | Const _ | Allocated_const _-> Typedtree.Constant
+      | Read_mutable _ | Read_symbol_field _ | Set_of_closures _
+      | Project_closure _ | Move_within_set_of_closures _ | Project_var _
+      | Prim _ | Expr _ -> rkind
+    in
+    (v, rkind, new_named)
 
 let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t =
   match tree with
@@ -187,7 +199,7 @@ let iter_all_immutable_let_and_let_rec_bindings t ~f =
   iter_expr (function
       | Let { var; defining_expr; _ } -> f var defining_expr
       | Let_rec (defs, _) ->
-        List.iter (fun (var, _clas, named) -> f var named) defs
+        List.iter (fun (var, _rkind, named) -> f var named) defs
       | _ -> ())
     t
 
@@ -196,7 +208,7 @@ let iter_all_toplevel_immutable_let_and_let_rec_bindings t ~f =
     (function
       | Let { var; defining_expr; _ } -> f var defining_expr
       | Let_rec (defs, _) ->
-        List.iter (fun (var, _clas, named) -> f var named) defs
+        List.iter (fun (var, _rkind, named) -> f var named) defs
       | _ -> ())
     (fun _ -> ())
     (Is_expr t)
@@ -311,8 +323,24 @@ let map_general ~toplevel f f_named tree =
         | Let_rec (defs, body) ->
           let done_something = ref false in
           let defs =
-            List.map (fun (id, clas, lam) ->
-                id, clas, aux_named_done_something id lam done_something)
+            List.map (fun (id, rkind, lam) ->
+                let new_named =
+                  aux_named_done_something id lam done_something
+                in
+                (* See comment in [map_rec_binding_sharing] *)
+                let new_rkind =
+                  match (new_named : Flambda.named) with
+                  | Symbol _ | Const _ | Allocated_const _->
+                    begin match (rkind : Typedtree.recursive_binding_kind) with
+                    | Constant -> ()
+                    | Static | Not_recursive | Class -> done_something := true
+                    end;
+                    Typedtree.Constant
+                  | Read_mutable _ | Read_symbol_field _ | Set_of_closures _
+                  | Project_closure _ | Move_within_set_of_closures _
+                  | Project_var _ | Prim _ | Expr _ -> rkind
+                in
+                id, new_rkind, new_named)
               defs
           in
           let body = aux_done_something body done_something in
diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml
index 0be0943a1b5..4cfea9fea14 100644
--- a/middle_end/flambda/flambda_to_clambda.ml
+++ b/middle_end/flambda/flambda_to_clambda.ml
@@ -246,14 +246,14 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
     Ulet (Mutable, contents_kind, VP.create id, def, to_clambda t env_body body)
   | Let_rec (defs, body) ->
     let env, defs =
-      List.fold_right (fun (var, clas, def) (env, defs) ->
+      List.fold_right (fun (var, rkind, def) (env, defs) ->
           let id, env = Env.add_fresh_ident env var in
-          env, (id, var, clas, def) :: defs)
+          env, (id, var, rkind, def) :: defs)
         defs (env, [])
     in
     let defs =
-      List.map (fun (id, var, clas, def) ->
-          VP.create id, clas, to_clambda_named t env var def)
+      List.map (fun (id, var, rkind, def) ->
+          VP.create id, rkind, to_clambda_named t env var def)
         defs
     in
     Uletrec (defs, to_clambda t env body)
diff --git a/middle_end/flambda/flambda_utils.ml b/middle_end/flambda/flambda_utils.ml
index 40a0f4997dd..52496bf96cd 100644
--- a/middle_end/flambda/flambda_utils.ml
+++ b/middle_end/flambda/flambda_utils.ml
@@ -221,14 +221,22 @@ and same_move_within_set_of_closures (m1 : Flambda.move_within_set_of_closures)
     && Closure_id.equal m1.start_from m2.start_from
     && Closure_id.equal m1.move_to m2.move_to
 
-and samebinding (v1, clas1, n1) (v2, clas2, n2) =
-  let equal_clas c1 c2 =
-    match (c1 : Typedtree.recursive_binding_kind),
-          (c2 : Typedtree.recursive_binding_kind) with
-    | Not_recursive, Not_recursive | Static, Static -> true
-    | Not_recursive, Static | Static, Not_recursive -> false
+and samebinding (v1, rkind1, n1) (v2, rkind2, n2) =
+  let equal_rkind rkind1 rkind2 =
+    match (rkind1 : Typedtree.recursive_binding_kind),
+          (rkind2 : Typedtree.recursive_binding_kind) with
+    | Not_recursive, Not_recursive
+    | Static, Static
+    | Constant, Constant
+    | Class, Class ->
+        true
+    | Not_recursive, (Static | Constant | Class)
+    | Static, (Not_recursive | Constant | Class)
+    | Constant, (Not_recursive | Static | Class)
+    | Class, (Not_recursive | Static | Constant) ->
+        false
   in
-  Variable.equal v1 v2 && equal_clas clas1 clas2 && same_named n1 n2
+  Variable.equal v1 v2 && equal_rkind rkind1 rkind2 && same_named n1 n2
 
 and sameswitch (fs1 : Flambda.switch) (fs2 : Flambda.switch) =
   let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in
@@ -660,8 +668,8 @@ let substitute_read_symbol_field_for_variables
           Variable.Map.of_set (fun var -> Variable.rename var) to_substitute
         in
         let defs =
-          List.map (fun (var, clas, named) ->
-              var, clas, substitute_named bindings named)
+          List.map (fun (var, rkind, named) ->
+              var, rkind, substitute_named bindings named)
             defs
         in
         let expr =
diff --git a/middle_end/flambda/inconstant_idents.ml b/middle_end/flambda/inconstant_idents.ml
index 2c802b8510a..9c091be8d77 100644
--- a/middle_end/flambda/inconstant_idents.ml
+++ b/middle_end/flambda/inconstant_idents.ml
@@ -236,7 +236,7 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
       mark_var var curr;
       mark_loop ~toplevel curr body
     | Let_rec(defs, body) ->
-      List.iter (fun (var, _clas, def) ->
+      List.iter (fun (var, _rkind, def) ->
           mark_named ~toplevel [Var var] def;
           (* adds 'var in NC => curr in NC' same remark as let case *)
           mark_var var curr)
diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml
index f21b18dd196..383a2818bf5 100644
--- a/middle_end/flambda/inline_and_simplify.ml
+++ b/middle_end/flambda/inline_and_simplify.ml
@@ -1138,14 +1138,14 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
     let defs, sb = Freshening.add_variables3 (E.freshening env) defs in
     let env = E.set_freshening env sb in
     let def_env =
-      List.fold_left (fun env_acc (id, _clas, _lam) ->
+      List.fold_left (fun env_acc (id, _rkind, _lam) ->
           E.add env_acc id (A.value_unknown Other))
         env defs
     in
     let defs, body_env, r =
-      List.fold_right (fun (id, clas, lam) (defs, env_acc, r) ->
+      List.fold_right (fun (id, rkind, lam) (defs, env_acc, r) ->
           let lam, r = simplify_named def_env r lam in
-          let defs = (id, clas, lam) :: defs in
+          let defs = (id, rkind, lam) :: defs in
           let env_acc = E.add env_acc id (R.approx r) in
           defs, env_acc, r)
         defs ([], env, r)
diff --git a/middle_end/flambda/lift_code.ml b/middle_end/flambda/lift_code.ml
index 40c1ef8cdaa..9f072d78ad7 100644
--- a/middle_end/flambda/lift_code.ml
+++ b/middle_end/flambda/lift_code.ml
@@ -122,13 +122,13 @@ module Sort_lets = Strongly_connected_components.Make (Variable)
 
 let rebuild_let_rec (defs:(Variable.t * _ * Flambda.named) list) body =
   let map =
-    List.fold_left (fun map (var, clas, def) ->
-        Variable.Map.add var (clas, def) map)
+    List.fold_left (fun map (var, rkind, def) ->
+        Variable.Map.add var (rkind, def) map)
       Variable.Map.empty defs
   in
   let graph =
     Variable.Map.map
-      (fun (_clas, named) ->
+      (fun (_rkind, named) ->
          Variable.Set.filter (fun v -> Variable.Map.mem v map)
            (Flambda.free_variables_named named))
       map
@@ -139,14 +139,14 @@ let rebuild_let_rec (defs:(Variable.t * _ * Flambda.named) list) body =
   Array.fold_left (fun body (component:Sort_lets.component) ->
       match component with
       | No_loop v ->
-          let (_clas, def) = Variable.Map.find v map in
+          let (_rkind, def) = Variable.Map.find v map in
           Flambda.create_let v def body
       | Has_loop l ->
           Flambda.Let_rec
             (List.map
                (fun v ->
-                  let clas, def = Variable.Map.find v map in
-                 v, clas, def)
+                  let rkind, def = Variable.Map.find v map in
+                 v, rkind, def)
                l,
              body))
     body components
diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.ml b/middle_end/flambda/lift_let_to_initialize_symbol.ml
index cfec4092023..b5720409091 100644
--- a/middle_end/flambda/lift_let_to_initialize_symbol.ml
+++ b/middle_end/flambda/lift_let_to_initialize_symbol.ml
@@ -102,12 +102,12 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets
       ~substitution
       ~copied_lets
       ~extracted_lets:(extracted::extracted_lets)
-  | Let_rec ([var, clas, named], body) ->
+  | Let_rec ([var, rkind, named], body) ->
     let renamed = Variable.rename var in
     let def_substitution = Variable.Map.add var renamed substitution in
     let expr =
       Flambda_utils.toplevel_substitution def_substitution
-        (Let_rec ([renamed, clas, named], Var renamed))
+        (Let_rec ([renamed, rkind, named], Var renamed))
     in
     let extracted = Expr (var, expr) in
     accumulate body
@@ -116,9 +116,9 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets
       ~extracted_lets:(extracted::extracted_lets)
   | Let_rec (defs, body) ->
     let renamed_defs, def_substitution =
-      List.fold_right (fun (var, clas, def) (acc, substitution) ->
+      List.fold_right (fun (var, rkind, def) (acc, substitution) ->
           let new_var = Variable.rename var in
-          (new_var, clas, def) :: acc,
+          (new_var, rkind, def) :: acc,
           Variable.Map.add var new_var substitution)
         defs ([], substitution)
     in
diff --git a/middle_end/flambda/ref_to_variables.ml b/middle_end/flambda/ref_to_variables.ml
index 1cbcffec8d4..e300c8ed8bb 100644
--- a/middle_end/flambda/ref_to_variables.ml
+++ b/middle_end/flambda/ref_to_variables.ml
@@ -45,7 +45,7 @@ let variables_not_used_as_local_reference (tree:Flambda.t) =
       loop_named defining_expr;
       loop body
     | Let_rec (defs, body) ->
-      List.iter (fun (_var, _clas, named) -> loop_named named) defs;
+      List.iter (fun (_var, _rkind, named) -> loop_named named) defs;
       loop body
     | Var v ->
       set := Variable.Set.add v !set
diff --git a/middle_end/flambda/un_anf.ml b/middle_end/flambda/un_anf.ml
index d69c161819e..9f1248a260a 100644
--- a/middle_end/flambda/un_anf.ml
+++ b/middle_end/flambda/un_anf.ml
@@ -57,7 +57,7 @@ let ignore_params_with_value_kind (_ : (VP.t * Lambda.value_kind) list) = ()
 let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
 let ignore_meth_kind (_ : Lambda.meth_kind) = ()
 let ignore_value_kind (_ : Lambda.value_kind) = ()
-let ignore_rec_classification (_ : Typedtree.recursive_binding_kind) = ()
+let ignore_rec_kind (_ : Typedtree.recursive_binding_kind) = ()
 
 (* CR-soon mshinwell: check we aren't traversing function bodies more than
    once (need to analyse exactly what the calls are from Cmmgen into this
@@ -168,9 +168,9 @@ let make_var_info (clam : Clambda.ulambda) : var_info =
       ignore_uphantom_defining_expr_option defining_expr_opt;
       loop ~depth body
     | Uletrec (defs, body) ->
-      List.iter (fun (var, clas, def) ->
+      List.iter (fun (var, rkind, def) ->
           ignore_var_with_provenance var;
-          ignore_rec_classification clas;
+          ignore_rec_kind rkind;
           loop ~depth def)
         defs;
       loop ~depth body
@@ -354,9 +354,9 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) =
       (* Evaluation order for [defs] is not defined, and this case
          probably isn't important for [Cmmgen] anyway. *)
       let_stack := [];
-      List.iter (fun (var, clas, def) ->
+      List.iter (fun (var, rkind, def) ->
           ignore_var_with_provenance var;
-          ignore_rec_classification clas;
+          ignore_rec_kind rkind;
           loop def;
           let_stack := [])
         defs;
@@ -520,8 +520,8 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda)
     Uphantom_let (var, defining_expr, body)
   | Uletrec (defs, body) ->
     let defs =
-      List.map (fun (var, clas, def) ->
-          var, clas, substitute_let_moveable is_let_moveable env def)
+      List.map (fun (var, rkind, def) ->
+          var, rkind, substitute_let_moveable is_let_moveable env def)
         defs
     in
     let body = substitute_let_moveable is_let_moveable env body in
@@ -746,7 +746,7 @@ let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda)
     Uphantom_let (var, defining_expr, body), body_moveable
   | Uletrec (defs, body) ->
     let defs =
-      List.map (fun (var, clas, def) -> var, clas, un_anf var_info env def) defs
+      List.map (fun (var, rk, def) -> var, rk, un_anf var_info env def) defs
     in
     let body = un_anf var_info env body in
     Uletrec (defs, body), Fixed
diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml
index 2d5897c2d59..11f61992f72 100644
--- a/middle_end/printclambda.ml
+++ b/middle_end/printclambda.ml
@@ -145,16 +145,18 @@ and lam ppf = function
       let bindings ppf id_arg_list =
         let spc = ref false in
         List.iter
-          (fun (id, clas, l) ->
+          (fun (id, rkind, l) ->
             if !spc then fprintf ppf "@ " else spc := true;
-            let clas_annot =
-              match (clas : Typedtree.recursive_binding_kind) with
+            let rec_annot =
+              match (rkind : Typedtree.recursive_binding_kind) with
               | Static -> ""
               | Not_recursive -> "[Nonrec]"
+              | Constant -> "[Cst]"
+              | Class -> "[Class]"
             in
             fprintf ppf "@[<2>%a%s@ %a@]"
               VP.print id
-              clas_annot
+              rec_annot
               lam l)
           id_arg_list in
       fprintf ppf
diff --git a/typing/rec_check.ml b/typing/rec_check.ml
index c03eec4d596..8abe92a9953 100644
--- a/typing/rec_check.ml
+++ b/typing/rec_check.ml
@@ -163,8 +163,24 @@ let classify_expression : Typedtree.expression -> sd =
 
     | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) ->
         classify_expression env e
-    | Texp_construct _ ->
-        Static
+    | Texp_construct (_, _, exprs) ->
+        let is_constant =
+          List.fold_left (fun is_constant expr ->
+              is_constant &&
+              match classify_expression env expr with
+              | Constant -> true
+              | _ -> false)
+            true exprs
+        in
+        if is_constant then Constant else Static
+
+    | Texp_variant (_, Some expr) ->
+        begin match classify_expression env expr with
+        | Constant -> Constant
+        | _ -> Static
+        end
+    | Texp_variant (_, None) ->
+        Constant
 
     | Texp_record { representation = Record_unboxed _;
                     fields = [| _, Overridden (_,e) |] } ->
@@ -181,24 +197,25 @@ let classify_expression : Typedtree.expression -> sd =
     | Texp_apply _ ->
         Not_recursive
 
-    | Texp_for _
-    | Texp_constant _
     | Texp_new _
     | Texp_instvar _
     | Texp_tuple _
     | Texp_array _
-    | Texp_variant _
-    | Texp_setfield _
-    | Texp_while _
-    | Texp_setinstvar _
     | Texp_pack _
     | Texp_object _
     | Texp_function _
     | Texp_lazy _
-    | Texp_unreachable
     | Texp_extension_constructor _ ->
         Static
 
+    | Texp_for _
+    | Texp_constant _
+    | Texp_setfield _
+    | Texp_while _
+    | Texp_setinstvar _
+    | Texp_unreachable ->
+        Constant
+
     | Texp_match _
     | Texp_ifthenelse _
     | Texp_send _
@@ -1286,12 +1303,18 @@ let is_valid_recursive_expression idlist expr : sd option =
         (* The expression has known size *)
         let ty = expression expr Return in
         if Env.unguarded ty idlist = [] then Some Static else None
+     | Constant ->
+        (* The expression will not be pre-allocated, but the result cannot
+           contain recursive references *)
+        let ty = expression expr Return in
+        if Env.unguarded ty idlist = [] then Some Constant else None
      | Not_recursive ->
         (* The expression has unknown size *)
         let ty = expression expr Return in
         if Env.unguarded ty idlist = [] && Env.dependent ty idlist = []
         then Some Not_recursive
         else None
+     | Class -> assert false (* Not generated by [classify_expression] *)
 
 (* A class declaration may contain let-bindings. If they are recursive,
    their validity will already be checked by [is_valid_recursive_expression]
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 42920e4b293..8ca029278ca 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -1982,7 +1982,7 @@ let approx_class_declarations env sdecls =
 
 open Format
 
-let non_virtual_string_of_kind = function
+let non_virtual_string_of_kind : kind -> string = function
   | Object -> "object"
   | Class -> "non-virtual class"
   | Class_type -> "non-virtual class type"
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index d0df9da8e31..4501945299c 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -35,6 +35,8 @@ type _ pattern_category =
 type recursive_binding_kind =
 | Not_recursive
 | Static
+| Constant
+| Class
 
 type pattern = value general_pattern
 and 'k general_pattern = 'k pattern_desc pattern_data
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 5309741026c..42e47540070 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -44,6 +44,8 @@ type _ pattern_category =
 type recursive_binding_kind =
 | Not_recursive
 | Static
+| Constant
+| Class
 
 type pattern = value general_pattern
 and 'k general_pattern = 'k pattern_desc pattern_data