Add Constant and Class classifications

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

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 *)
 

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 ****)
 

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

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

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

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

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

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

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)

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 =

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)

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)

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

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

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