Add Constant and Class classifications

Use that to assert that Static bindings always have a known size

asmcomp/cmmgen.ml

@@ -224,8 +224,17 @@ let rec expr_size env = function
 
 let expr_size_of_binding (clas : Lambda.rec_check_classification) expr =
   match clas with
-  | Dynamic -> RHS_nonrec
-  | Static -> expr_size V.empty expr
+  | Dynamic | 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
+      assert (result <> RHS_nonrec);
+      result
 
 (* Translate structured constants to Cmm data items *)
 

bytecomp/bytegen.ml

@@ -312,8 +312,17 @@ let rec size_of_lambda env = function
 
 let size_of_rec_binding clas expr =
   match (clas : Lambda.rec_check_classification) with
-  | Dynamic -> RHS_nonrec
-  | Static -> size_of_lambda Ident.empty expr
+  | Dynamic | 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 ****)
 

lambda/lambda.ml

@@ -266,7 +266,7 @@ type function_kind = Curried | Tupled
 
 type let_kind = Strict | Alias | StrictOpt
 
-type rec_check_classification = Static | Dynamic
+type rec_check_classification = Static | Dynamic | Constant | Class
 
 type meth_kind = Self | Public | Cached
 

lambda/lambda.mli

@@ -258,7 +258,7 @@ type let_kind = Strict | Alias | StrictOpt
       we can discard e if x does not appear in e'
  *)
 
-type rec_check_classification = Static | Dynamic
+type rec_check_classification = Static | Dynamic | Constant | Class
 
 type meth_kind = Self | Public | Cached
 

lambda/printlambda.ml

@@ -587,6 +587,8 @@ let rec lam ppf = function
               match (clas : Lambda.rec_check_classification) with
               | Static -> ""
               | Dynamic -> "[Dyn]"
+              | Constant -> "[Cst]"
+              | Class -> "[Class]"
             in
             fprintf ppf "@[<2>%a%s@ %a@]" Ident.print id clas_annot lam l)
           id_arg_list in

lambda/translmod.ml

@@ -425,7 +425,7 @@ let transl_class_bindings ~scopes cl_list =
   (ids,
    List.map
      (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) ->
-       (id, Static, transl_class ~scopes ids id meths cl vf))
+       (id, Class, transl_class ~scopes ids id meths cl vf))
      cl_list)
 
 (* Compile one or more functors, merging curried functors to produce

middle_end/flambda/flambda.ml

@@ -261,6 +261,8 @@ let rec lam ppf (flam : t) =
                match (clas : Lambda.rec_check_classification) with
                | Static -> ""
                | Dynamic -> "[Dyn]"
+               | Constant -> "[Cst]"
+               | Class -> "[Class]"
              in
              fprintf ppf "@[<2>%a%s@ %a@]"
                Variable.print id clas_annot print_named l)

middle_end/flambda/flambda_iterators.ml

@@ -79,6 +79,18 @@ let map_rec_binding_sharing f ((v, clas, named) as binding) =
   if named == new_named then
     binding
   else
+    let clas =
+      (* We could be replacing an expression with arbitrary classification
+         by a constant, in which case we need to change the classification.
+         Mode conditions for the [Constant] classification are not stricter
+         than any other classification, so we do not need to re-check the
+         modes. *)
+      match (new_named : Flambda.named) with
+      | Symbol _ | Const _ | Allocated_const _-> Lambda.Constant
+      | Read_mutable _ | Read_symbol_field _ | Set_of_closures _
+      | Project_closure _ | Move_within_set_of_closures _ | Project_var _
+      | Prim _ | Expr _ -> clas
+    in
     (v, clas, new_named)
 
 let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t =
@@ -312,7 +324,23 @@ let map_general ~toplevel f f_named tree =
           let done_something = ref false in
           let defs =
             List.map (fun (id, clas, lam) ->
-                id, clas, aux_named_done_something id lam done_something)
+                let new_named =
+                  aux_named_done_something id lam done_something
+                in
+                (* See comment in [map_rec_binding_sharing] *)
+                let new_clas =
+                  match (new_named : Flambda.named) with
+                  | Symbol _ | Const _ | Allocated_const _->
+                    begin match (clas : Lambda.rec_check_classification) with
+                    | Constant -> ()
+                    | Static | Dynamic | Class -> done_something := true
+                    end;
+                    Lambda.Constant
+                  | Read_mutable _ | Read_symbol_field _ | Set_of_closures _
+                  | Project_closure _ | Move_within_set_of_closures _
+                  | Project_var _ | Prim _ | Expr _ -> clas
+                in
+                id, new_clas, new_named)
               defs
           in
           let body = aux_done_something body done_something in

middle_end/flambda/flambda_utils.ml

@@ -225,8 +225,15 @@ and samebinding (v1, clas1, n1) (v2, clas2, n2) =
   let equal_clas c1 c2 =
     match (c1 : Lambda.rec_check_classification),
           (c2 : Lambda.rec_check_classification) with
-    | Dynamic, Dynamic | Static, Static -> true
-    | Dynamic, Static | Static, Dynamic -> false
+    | Dynamic, Dynamic
+    | Static, Static
+    | Constant, Constant
+    | Class, Class ->
+        true
+    | Dynamic, (Static | Constant | Class)
+    | Static, (Dynamic | Constant | Class)
+    | Constant, (Dynamic | Static | Class)
+    | Class, (Dynamic | Static | Constant) -> false
   in
   Variable.equal v1 v2 && equal_clas clas1 clas2 && same_named n1 n2
 

middle_end/printclambda.ml

@@ -151,6 +151,8 @@ and lam ppf = function
               match (clas : Lambda.rec_check_classification) with
               | Static -> ""
               | Dynamic -> "[Dyn]"
+              | Constant -> "[Cst]"
+              | Class -> "[Class]"
             in
             fprintf ppf "@[<2>%a%s@ %a@]"
               VP.print id

typing/rec_check.ml

@@ -159,8 +159,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) |] } ->
@@ -177,21 +193,22 @@ let classify_expression : Typedtree.expression -> sd =
     | Texp_apply _ ->
         Dynamic
 
-    | Texp_for _
-    | Texp_constant _
     | Texp_tuple _
     | Texp_array _
-    | Texp_variant _
-    | Texp_setfield _
-    | Texp_while _
-    | Texp_setinstvar _
     | Texp_pack _
     | Texp_function _
     | Texp_lazy _
-    | Texp_unreachable
     | Texp_extension_constructor _ ->
         Static
 
+    | Texp_for _
+    | Texp_constant _
+    | Texp_setfield _
+    | Texp_while _
+    | Texp_setinstvar _
+    | Texp_unreachable ->
+        Constant
+
     | Texp_new _
     | Texp_instvar _
     | Texp_object _
@@ -1282,12 +1299,18 @@ let is_valid_recursive_expression idlist expr =
         (* The expression has known size *)
         let ty = expression expr Return in
         if Env.unguarded ty idlist = [] then Some Lambda.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 Lambda.Constant else None
      | Dynamic ->
         (* The expression has unknown size *)
         let ty = expression expr Return in
         if Env.unguarded ty idlist = [] && Env.dependent ty idlist = []
         then Some Lambda.Dynamic
         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]