diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml
index 35c149867c8c..aac55b1ebf39 100644
--- a/middle_end/clambda.ml
+++ b/middle_end/clambda.ml
@@ -127,6 +127,7 @@ type preallocated_block = {
   tag : int;
   fields : uconstant_block_field option list;
   provenance : usymbol_provenance option;
+  block_desc : Block_desc.t;
 }
 
 type preallocated_constant = {
diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli
index c86f2d674ea5..e55c192bd0ba 100644
--- a/middle_end/clambda.mli
+++ b/middle_end/clambda.mli
@@ -143,6 +143,7 @@ type preallocated_block = {
   tag : int;
   fields : uconstant_block_field option list;
   provenance : usymbol_provenance option;
+  block_desc : Block_desc.t;
 }
 
 type preallocated_constant = {
diff --git a/middle_end/closure/closure_middle_end.ml b/middle_end/closure/closure_middle_end.ml
index 0d191fc26c37..7a77cb14b0cd 100644
--- a/middle_end/closure/closure_middle_end.ml
+++ b/middle_end/closure/closure_middle_end.ml
@@ -47,6 +47,7 @@ let lambda_to_clambda ~backend ~prefixname:_ ~ppf_dump
       tag = 0;
       fields = List.init lambda.main_module_block_size (fun _ -> None);
       provenance = Some provenance;
+      block_desc = Block_desc.empty;
     }
   in
   let constants = Compilenv.structured_constants () in
diff --git a/middle_end/flambda/alias_analysis.ml b/middle_end/flambda/alias_analysis.ml
index fe97a36f5176..6d59590d2b58 100644
--- a/middle_end/flambda/alias_analysis.ml
+++ b/middle_end/flambda/alias_analysis.ml
@@ -28,7 +28,7 @@ type allocated_const =
 
 type constant_defining_value =
   | Allocated_const of allocated_const
-  | Block of Tag.t * Variable.t list
+  | Block of Tag.t * Variable.t list * Block_desc.t
   | Set_of_closures of Flambda.set_of_closures
   | Project_closure of Flambda.project_closure
   | Move_within_set_of_closures of Flambda.move_within_set_of_closures
@@ -54,10 +54,11 @@ let print_constant_defining_value ppf = function
       (Format.pp_print_list Variable.print) vars
   | Allocated_const (Duplicate_array (_, _, var)) ->
     Format.fprintf ppf "dup_array(%a)" Variable.print var
-  | Block (tag, vars) ->
-    Format.fprintf ppf "[|%a: %a|]"
+  | Block (tag, vars, desc) ->
+    Format.fprintf ppf "[|%a: %a (%a)|]"
       Tag.print tag
       (Format.pp_print_list Variable.print) vars
+      Block_desc.format desc
   | Set_of_closures set -> Flambda.print_set_of_closures ppf set
   | Project_closure project -> Flambda.print_project_closure ppf project
   | Move_within_set_of_closures move ->
@@ -114,7 +115,7 @@ and fetch_variable_field
     (field: int)
     ~the_dead_constant : allocation_point =
   match Variable.Tbl.find definitions.variable var with
-  | Block (_, fields) ->
+  | Block (_, fields, _) ->
     begin match List.nth fields field with
     | exception Not_found -> Symbol the_dead_constant
     | v -> fetch_variable definitions v ~the_dead_constant
@@ -134,7 +135,7 @@ and fetch_symbol_field
     (field: int)
     ~the_dead_constant : allocation_point =
   match Symbol.Tbl.find definitions.symbol sym with
-  | Block (_, fields) ->
+  | Block (_, fields, _) ->
     begin match List.nth fields field with
     | exception Not_found -> Symbol the_dead_constant
     | Symbol s -> Symbol s
diff --git a/middle_end/flambda/alias_analysis.mli b/middle_end/flambda/alias_analysis.mli
index 515daeffa34b..438daae0254d 100644
--- a/middle_end/flambda/alias_analysis.mli
+++ b/middle_end/flambda/alias_analysis.mli
@@ -27,7 +27,7 @@ type allocated_const =
 
 type constant_defining_value =
   | Allocated_const of allocated_const
-  | Block of Tag.t * Variable.t list
+  | Block of Tag.t * Variable.t list * Block_desc.t
   | Set_of_closures of Flambda.set_of_closures
   | Project_closure of Flambda.project_closure
   | Move_within_set_of_closures of Flambda.move_within_set_of_closures
diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml
index 9646531baf27..c188f801c71e 100644
--- a/middle_end/flambda/build_export_info.ml
+++ b/middle_end/flambda/build_export_info.ml
@@ -265,22 +265,22 @@ and descr_of_named (env : Env.t) (named : Flambda.named)
   | Read_mutable _ -> Value_unknown
   | Read_symbol_field (sym, i) ->
     begin match Env.get_symbol_descr env sym with
-    | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
+    | Some (Value_block (_, fields, _)) when Array.length fields > i -> fields.(i)
     | _ -> Value_unknown
     end
   | Const const ->
     Value_id (Env.new_descr env (descr_of_constant const))
   | Allocated_const const ->
     Value_id (Env.new_descr env (descr_of_allocated_constant const))
-  | Prim (Pmakeblock (tag, Immutable, _value_kind, _bdesc), args, _dbg) ->
+  | Prim (Pmakeblock (tag, Immutable, _value_kind, desc), args, _dbg) ->
     let approxs = List.map (Env.find_approx env) args in
     let descr : Export_info.descr =
-      Value_block (Tag.create_exn tag, Array.of_list approxs)
+      Value_block (Tag.create_exn tag, Array.of_list approxs, desc)
     in
     Value_id (Env.new_descr env descr)
   | Prim (Pfield (i, _, _), [arg], _) ->
     begin match Env.get_descr env (Env.find_approx env arg) with
-    | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
+    | Some (Value_block (_, fields, _)) when Array.length fields > i -> fields.(i)
     | _ -> Value_unknown
     end
   | Prim _ -> Value_unknown
@@ -414,11 +414,11 @@ let describe_constant_defining_value env export_id symbol
   | Allocated_const alloc_const ->
     let descr = descr_of_allocated_constant alloc_const in
     Env.record_descr env export_id descr
-  | Block (tag, fields) ->
+  | Block (tag, fields, desc) ->
     let approxs =
       List.map (approx_of_constant_defining_value_block_field env) fields
     in
-    Env.record_descr env export_id (Value_block (tag, Array.of_list approxs))
+    Env.record_descr env export_id (Value_block (tag, Array.of_list approxs, desc))
   | Set_of_closures set_of_closures ->
     let descr : Export_info.descr =
       Value_set_of_closures
@@ -497,7 +497,7 @@ let describe_program (env : Env.Global.t) (program : Flambda.program) =
             ~symbols_being_defined def)
         project_closures;
       loop env program
-    | Initialize_symbol (symbol, tag, fields, program) ->
+    | Initialize_symbol (symbol, tag, fields, desc, program) ->
       let id =
         let env =
           (* Assignments of variables to export IDs are local to each
@@ -507,7 +507,7 @@ let describe_program (env : Env.Global.t) (program : Flambda.program) =
         in
         let field_approxs = List.map (approx_of_expr env) fields in
         let descr : Export_info.descr =
-          Value_block (tag, Array.of_list field_approxs)
+          Value_block (tag, Array.of_list field_approxs, desc)
         in
         Env.new_descr env descr
       in
diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml
index e2c422f697cc..4e66a0d0f256 100644
--- a/middle_end/flambda/closure_conversion.ml
+++ b/middle_end/flambda/closure_conversion.ml
@@ -130,10 +130,11 @@ let rec declare_const t (const : Lambda.structured_constant)
     register_const t
       (Allocated_const (Immutable_float_array (List.map float_of_string c)))
       Names.const_float_array
-  | Const_block (tag, consts, _) ->
+  | Const_block (tag, consts, desc) ->
     let const : Flambda.constant_defining_value =
       Block (Tag.create_exn tag,
-             List.map (fun c -> fst (declare_const t c)) consts)
+             List.map (fun c -> fst (declare_const t c)) consts,
+             desc)
     in
     register_const t const Names.const_block
 
@@ -680,10 +681,12 @@ let lambda_to_flambda ~backend ~module_ident ~size lam
       block_symbol,
       Tag.create_exn 0,
       [close t Env.empty lam],
+      Block_desc.empty,
       Initialize_symbol (
         module_symbol,
         Tag.create_exn 0,
         Array.to_list fields,
+        Block_desc.empty,
         End module_symbol))
   in
   let program_body =
diff --git a/middle_end/flambda/export_info.ml b/middle_end/flambda/export_info.ml
index dc47be5e1ba8..2919dfb6b89a 100644
--- a/middle_end/flambda/export_info.ml
+++ b/middle_end/flambda/export_info.ml
@@ -37,7 +37,7 @@ type value_float_array = {
 }
 
 type descr =
-  | Value_block of Tag.t * approx array
+  | Value_block of Tag.t * approx array * Block_desc.t
   | Value_mutable_block of Tag.t * int
   | Value_int of int
   | Value_char of char
@@ -103,8 +103,9 @@ let equal_descr (d1:descr) (d2:descr) : bool =
   match d1, d2 with
   | Value_unknown_descr, Value_unknown_descr ->
     true
-  | Value_block (t1, f1), Value_block (t2, f2) ->
+  | Value_block (t1, f1, desc1), Value_block (t2, f2, desc2) ->
     Tag.equal t1 t2 && equal_array equal_approx f1 f2
+    && Block_desc.compare desc1 desc2 = 0
   | Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) ->
     Tag.equal t1 t2 &&
     s1 = s2
@@ -125,12 +126,12 @@ let equal_descr (d1:descr) (d2:descr) : bool =
     equal_set_of_closures c1.set_of_closures c2.set_of_closures
   | Value_set_of_closures s1, Value_set_of_closures s2 ->
     equal_set_of_closures s1 s2
-  | ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
+  | ( Value_block (_, _, _) | Value_mutable_block (_, _) | Value_int _
     | Value_char _ | Value_float _ | Value_float_array _
     | Value_boxed_int _ | Value_string _ | Value_closure _
     | Value_set_of_closures _
     | Value_unknown_descr ),
-    ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
+    ( Value_block (_, _, _) | Value_mutable_block (_, _) | Value_int _
     | Value_char _ | Value_float _ | Value_float_array _
     | Value_boxed_int _ | Value_string _ | Value_closure _
     | Value_set_of_closures _
@@ -385,10 +386,11 @@ let print_raw_descr ppf descr =
     Array.iter (fun approx -> fprintf ppf "%a " print_raw_approx approx) arr
   in
   match descr with
-  | Value_block (tag, approx_array) ->
-    fprintf ppf "(Value_block (%a %a))"
+  | Value_block (tag, approx_array, desc) ->
+    fprintf ppf "(Value_block (%a %a (%a)))"
       Tag.print tag
       print_approx_array approx_array
+      Block_desc.format desc
   | Value_mutable_block (tag, i) ->
     fprintf ppf "(Value_mutable-block (%a %d))" Tag.print tag i
   | Value_int i -> fprintf ppf "(Value_int %d)" i
@@ -441,8 +443,9 @@ let print_approx_components ppf ~symbol_id ~values
     match descr with
     | Value_int i -> Format.pp_print_int ppf i
     | Value_char c -> fprintf ppf "%c" c
-    | Value_block (tag, fields) ->
-      fprintf ppf "[%a:%a]" Tag.print tag print_fields fields
+    | Value_block (tag, fields, desc) ->
+      fprintf ppf "[%a:%a(%a)]" Tag.print tag print_fields fields
+        Block_desc.format desc
     | Value_mutable_block (tag, size) ->
       fprintf ppf "[mutable %a:%i]" Tag.print tag size
     | Value_closure {closure_id; set_of_closures} ->
diff --git a/middle_end/flambda/export_info.mli b/middle_end/flambda/export_info.mli
index 4068a168d2de..d89c21bba8a4 100644
--- a/middle_end/flambda/export_info.mli
+++ b/middle_end/flambda/export_info.mli
@@ -40,7 +40,7 @@ type value_float_array = {
 }
 
 type descr =
-  | Value_block of Tag.t * approx array
+  | Value_block of Tag.t * approx array * Block_desc.t
   | Value_mutable_block of Tag.t * int
   | Value_int of int
   | Value_char of char
diff --git a/middle_end/flambda/export_info_for_pack.ml b/middle_end/flambda/export_info_for_pack.ml
index 981bdfda9274..28a60b4585e8 100644
--- a/middle_end/flambda/export_info_for_pack.ml
+++ b/middle_end/flambda/export_info_for_pack.ml
@@ -104,8 +104,8 @@ let import_descr_for_pack units pack (descr : Export_info.descr)
   | Value_float_array _
   | Export_info.Value_boxed_int _
   | Value_mutable_block _ as desc -> desc
-  | Value_block (tag, fields) ->
-    Value_block (tag, Array.map (import_approx_for_pack units pack) fields)
+  | Value_block (tag, fields, desc) ->
+    Value_block (tag, Array.map (import_approx_for_pack units pack) fields, desc)
   | Value_closure { closure_id; set_of_closures } ->
     Value_closure {
       closure_id;
diff --git a/middle_end/flambda/extract_projections.ml b/middle_end/flambda/extract_projections.ml
index 079b87929eaf..f398b40c004b 100644
--- a/middle_end/flambda/extract_projections.ml
+++ b/middle_end/flambda/extract_projections.ml
@@ -69,7 +69,7 @@ let known_valid_projections ~env ~projections ~which_variables =
       | Field (field_index, _) ->
         match A.check_approx_for_block approx with
         | Wrong -> false
-        | Ok (_tag, fields) ->
+        | Ok (_tag, fields, _desc) ->
           field_index >= 0 && field_index < Array.length fields)
     projections
 
diff --git a/middle_end/flambda/flambda.ml b/middle_end/flambda/flambda.ml
index d2ee65b2fd49..ad9284cf5ad2 100644
--- a/middle_end/flambda/flambda.ml
+++ b/middle_end/flambda/flambda.ml
@@ -148,7 +148,7 @@ and for_loop = {
 
 and constant_defining_value =
   | Allocated_const of Allocated_const.t
-  | Block of Tag.t * constant_defining_value_block_field list
+  | Block of Tag.t * constant_defining_value_block_field list * Block_desc.t
   | Set_of_closures of set_of_closures  (* [free_vars] must be empty *)
   | Project_closure of Symbol.t * Closure_id.t
 
@@ -161,7 +161,7 @@ type expr = t
 type program_body =
   | Let_symbol of Symbol.t * constant_defining_value * program_body
   | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body
-  | Initialize_symbol of Symbol.t * Tag.t * t list * program_body
+  | Initialize_symbol of Symbol.t * Tag.t * t list * Block_desc.t * program_body
   | Effect of t * program_body
   | End of Symbol.t
 
@@ -437,8 +437,9 @@ let print_constant_defining_value ppf (const : constant_defining_value) =
   match const with
   | Allocated_const const ->
     fprintf ppf "(Allocated_const %a)" Allocated_const.print const
-  | Block (tag, []) -> fprintf ppf "(Atom (tag %d))" (Tag.to_int tag)
-  | Block (tag, fields) ->
+  | Block (tag, [], desc) ->
+    fprintf ppf "(Atom (tag %d) %a)" (Tag.to_int tag) Block_desc.format desc
+  | Block (tag, fields, desc) ->
     let print_field ppf (field : constant_defining_value_block_field) =
       match field with
       | Symbol symbol -> Symbol.print ppf symbol
@@ -447,8 +448,9 @@ let print_constant_defining_value ppf (const : constant_defining_value) =
     let print_fields ppf =
       List.iter (fprintf ppf "@ %a" print_field)
     in
-    fprintf ppf "(Block (tag %d, %a))" (Tag.to_int tag)
+    fprintf ppf "(Block (tag %d, %a, %a))" (Tag.to_int tag)
       print_fields fields
+      Block_desc.format desc
   | Set_of_closures set_of_closures ->
     fprintf ppf "@[<2>(Set_of_closures (@ %a))@]" print_set_of_closures
       set_of_closures
@@ -481,11 +483,12 @@ let rec print_program_body ppf (program : program_body) =
       "@[<2>let_rec_symbol@ @[%a@]@]@."
       (Format.pp_print_list symbol_binding) defs;
     print_program_body ppf program
-  | Initialize_symbol (symbol, tag, fields, program) ->
-    fprintf ppf "@[<2>initialize_symbol@ (@[<2>%a@ %a@ %a@])@]@."
+  | Initialize_symbol (symbol, tag, fields, desc, program) ->
+    fprintf ppf "@[<2>initialize_symbol@ (@[<2>%a@ %a@ %a@ %a@])@]@."
       Symbol.print symbol
       Tag.print tag
-      (Format.pp_print_list lam) fields;
+      (Format.pp_print_list lam) fields
+      Block_desc.format desc;
     print_program_body ppf program
   | Effect (expr, program) ->
     fprintf ppf "@[<2>effect@ %a@]@."
@@ -929,7 +932,7 @@ let free_symbols_allocated_constant_helper symbols
       (const : constant_defining_value) =
   match const with
   | Allocated_const _ -> ()
-  | Block (_, fields) ->
+  | Block (_, fields, _) ->
     List.iter
       (function
         | (Symbol s : constant_defining_value_block_field) ->
@@ -954,7 +957,7 @@ let free_symbols_program (program : program) =
           free_symbols_allocated_constant_helper symbols const)
         defs;
       loop program
-    | Initialize_symbol (_, _, fields, program) ->
+    | Initialize_symbol (_, _, fields, _desc, program) ->
       List.iter (fun field ->
           symbols := Symbol.Set.union !symbols (free_symbols field))
         fields;
@@ -1193,12 +1196,15 @@ module Constant_defining_value = struct
       match t1, t2 with
       | Allocated_const c1, Allocated_const c2 ->
         Allocated_const.compare c1 c2
-      | Block (tag1, fields1), Block (tag2, fields2) ->
+      | Block (tag1, fields1, desc1), Block (tag2, fields2, desc2) ->
         let c = Tag.compare tag1 tag2 in
-        if c <> 0 then c
-        else
-          Misc.Stdlib.List.compare compare_constant_defining_value_block_field
-            fields1 fields2
+        if c <> 0 then c else
+          let c =
+            Misc.Stdlib.List.compare compare_constant_defining_value_block_field
+              fields1 fields2
+          in
+          if c <> 0 then c else
+            Block_desc.compare desc1 desc2
       | Set_of_closures set1, Set_of_closures set2 ->
         Set_of_closures_id.compare set1.function_decls.set_of_closures_id
           set2.function_decls.set_of_closures_id
diff --git a/middle_end/flambda/flambda.mli b/middle_end/flambda/flambda.mli
index 4e58505b827d..db4ff140263a 100644
--- a/middle_end/flambda/flambda.mli
+++ b/middle_end/flambda/flambda.mli
@@ -354,7 +354,7 @@ and constant_defining_value =
   | Allocated_const of Allocated_const.t
     (** A single constant.  These are never "simple constants" (type [const])
         but instead more complicated constructions. *)
-  | Block of Tag.t * constant_defining_value_block_field list
+  | Block of Tag.t * constant_defining_value_block_field list * Block_desc.t
     (** A pre-allocated block full of constants (either simple constants
         or references to other constants, see below). *)
   | Set_of_closures of set_of_closures
@@ -399,7 +399,7 @@ type program_body =
       approximation of the set of closures to be present in order to
       correctly simplify the [Project_closure] construction.  (See
       [Inline_and_simplify.simplify_project_closure] for that part.) *)
-  | Initialize_symbol of Symbol.t * Tag.t * t list * program_body
+  | Initialize_symbol of Symbol.t * Tag.t * t list * Block_desc.t * program_body
   (** Define the given symbol as a constant block of the given size and
       tag; but with a possibly non-constant initializer.  The initializer
       will be executed at most once (from the entry point of the compilation
diff --git a/middle_end/flambda/flambda_invariants.ml b/middle_end/flambda/flambda_invariants.ml
index b5890fe7ccc7..bea9da049718 100644
--- a/middle_end/flambda/flambda_invariants.ml
+++ b/middle_end/flambda/flambda_invariants.ml
@@ -50,6 +50,7 @@ let ignore_tag (_ : Tag.t) = ()
 let ignore_inline_attribute (_ : Lambda.inline_attribute) = ()
 let ignore_specialise_attribute (_ : Lambda.specialise_attribute) = ()
 let ignore_value_kind (_ : Lambda.value_kind) = ()
+let ignore_block_desc (_ : Block_desc.t) = ()
 
 exception Binding_occurrence_not_from_current_compilation_unit of Variable.t
 exception Mutable_binding_occurrence_not_from_current_compilation_unit of
@@ -387,13 +388,14 @@ let variable_and_symbol_invariants (program : Flambda.program) =
     match const with
     | Flambda.Allocated_const c ->
       ignore_allocated_const c
-    | Flambda.Block (tag,fields) ->
+    | Flambda.Block (tag,fields,desc) ->
       ignore_tag tag;
       List.iter (fun (fields : Flambda.constant_defining_value_block_field) ->
           match fields with
           | Const c -> ignore_const c
           | Symbol s -> check_symbol_is_bound env s)
-        fields
+        fields;
+      ignore_block_desc desc
     | Flambda.Set_of_closures set_of_closures ->
       loop_set_of_closures env set_of_closures;
       (* Constant set of closures must not have free variables *)
@@ -421,7 +423,7 @@ let variable_and_symbol_invariants (program : Flambda.program) =
       loop_constant_defining_value env def;
       let env = add_binding_occurrence_of_symbol env symbol in
       loop_program_body env program
-    | Initialize_symbol (symbol, _tag, fields, program) ->
+    | Initialize_symbol (symbol, _tag, fields, _desc, program) ->
       List.iter (loop env) fields;
       let env = add_binding_occurrence_of_symbol env symbol in
       loop_program_body env program
diff --git a/middle_end/flambda/flambda_iterators.ml b/middle_end/flambda/flambda_iterators.ml
index 06b5b232999c..3717ea26ea82 100644
--- a/middle_end/flambda/flambda_iterators.ml
+++ b/middle_end/flambda/flambda_iterators.ml
@@ -206,7 +206,7 @@ let iter_exprs_at_toplevel_of_program (program : Flambda.program) ~f =
       loop program
     | Let_symbol (_, _, program) ->
       loop program
-    | Initialize_symbol (_, _, fields, program) ->
+    | Initialize_symbol (_, _, fields, _, program) ->
       List.iter f fields;
       loop program
     | Effect (expr, program) ->
@@ -240,7 +240,7 @@ let iter_on_set_of_closures_of_program (program : Flambda.program) ~f =
       loop program
     | Let_symbol (_, _, program) ->
       loop program
-    | Initialize_symbol (_, _, fields, program) ->
+    | Initialize_symbol (_, _, fields, _, program) ->
       List.iter (iter_on_sets_of_closures (f ~constant:false)) fields;
       loop program
     | Effect (expr, program) ->
@@ -259,7 +259,7 @@ let iter_constant_defining_values_on_program (program : Flambda.program) ~f =
     | Let_rec_symbol (defs, program) ->
       List.iter (fun (_, const) -> f const) defs;
       loop program
-    | Initialize_symbol (_, _, _, program) ->
+    | Initialize_symbol (_, _, _, _, program) ->
       loop program
     | Effect (_, program) ->
       loop program
@@ -636,7 +636,7 @@ let map_sets_of_closures_of_program (program : Flambda.program)
         program
       else
         Let_rec_symbol (defs, loop program')
-    | Initialize_symbol (symbol, tag, fields, program') ->
+    | Initialize_symbol (symbol, tag, fields, desc, program') ->
       let done_something = ref false in
       let fields =
         List.map (fun field ->
@@ -651,7 +651,7 @@ let map_sets_of_closures_of_program (program : Flambda.program)
       if new_program' == program' && not !done_something then
         program
       else
-        Initialize_symbol (symbol, tag, fields, new_program')
+        Initialize_symbol (symbol, tag, fields, desc, new_program')
     | Effect (expr, program') ->
       let new_expr = map_sets_of_closures expr ~f in
       let new_program' = loop program' in
@@ -730,7 +730,7 @@ let map_exprs_at_toplevel_of_program (program : Flambda.program)
         program
       else
         Let_rec_symbol (defs, new_program')
-    | Initialize_symbol (symbol, tag, fields, program') ->
+    | Initialize_symbol (symbol, tag, fields, desc, program') ->
       let done_something = ref false in
       let fields =
         List.map (fun field ->
@@ -745,7 +745,7 @@ let map_exprs_at_toplevel_of_program (program : Flambda.program)
       if new_program' == program' && not !done_something then
         program
       else
-        Initialize_symbol (symbol, tag, fields, new_program')
+        Initialize_symbol (symbol, tag, fields, desc, new_program')
     | Effect (expr, program') ->
       let new_expr = f expr in
       let new_program' = loop program' in
diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml
index ac0774249aec..5a18bb8d07a1 100644
--- a/middle_end/flambda/flambda_to_clambda.ml
+++ b/middle_end/flambda/flambda_to_clambda.ml
@@ -611,10 +611,10 @@ let accumulate_structured_constants t env symbol
   match c with
   | Allocated_const c ->
     Symbol.Map.add symbol (to_clambda_allocated_constant c) acc
-  | Block (tag, fields) ->
+  | Block (tag, fields, desc) ->
     let fields = List.map (to_clambda_const env) fields in
     Symbol.Map.add symbol
-      (Clambda.Uconst_block (Tag.to_int tag, fields, Block_desc.empty)) acc
+      (Clambda.Uconst_block (Tag.to_int tag, fields, desc)) acc
   | Set_of_closures set_of_closures ->
     let to_clambda_set_of_closures =
       to_clambda_closed_set_of_closures t env symbol set_of_closures
@@ -648,7 +648,7 @@ let to_clambda_program t env constants (program : Flambda.program) =
           constants defs
       in
       loop env constants program
-    | Initialize_symbol (symbol, tag, fields, program) ->
+    | Initialize_symbol (symbol, tag, fields, desc, program) ->
       let fields =
         List.mapi (fun i field ->
             i, field,
@@ -684,6 +684,7 @@ let to_clambda_program t env constants (program : Flambda.program) =
           tag = Tag.to_int tag;
           fields = constant_fields;
           provenance = None;
+          block_desc = desc;
         }
       in
       let e2, constants, preallocated_blocks = loop env constants program in
diff --git a/middle_end/flambda/flambda_utils.ml b/middle_end/flambda/flambda_utils.ml
index e6cf4c4f1ed1..abc631e2b72e 100644
--- a/middle_end/flambda/flambda_utils.ml
+++ b/middle_end/flambda/flambda_utils.ml
@@ -407,7 +407,7 @@ let all_lifted_constants (program : Flambda.program) =
       List.fold_left (fun l (symbol, decl) -> (symbol, decl) :: l)
         (loop program)
         decls
-    | Initialize_symbol (_, _, _, program)
+    | Initialize_symbol (_, _, _, _, program)
     | Effect (_, program) -> loop program
     | End _ -> []
   in
@@ -419,8 +419,8 @@ let all_lifted_constants_as_map program =
 let initialize_symbols (program : Flambda.program) =
   let rec loop (program : Flambda.program_body) =
     match program with
-    | Initialize_symbol (symbol, tag, fields, program) ->
-      (symbol, tag, fields) :: (loop program)
+    | Initialize_symbol (symbol, tag, fields, desc, program) ->
+      (symbol, tag, fields, desc) :: (loop program)
     | Effect (_, program)
     | Let_symbol (_, _, program)
     | Let_rec_symbol (_, program) -> loop program
@@ -438,7 +438,7 @@ let needed_import_symbols (program : Flambda.program) =
       (Symbol.Set.of_list
          (List.map fst (all_lifted_constants program)))
       (Symbol.Set.of_list
-         (List.map (fun (s, _, _) -> s) (initialize_symbols program)))
+         (List.map (fun (s, _, _, _) -> s) (initialize_symbols program)))
   in
   Symbol.Set.diff dependencies defined_symbol
 
@@ -453,7 +453,7 @@ let root_symbol (program : Flambda.program) =
     | Effect (_, program)
     | Let_symbol (_, _, program)
     | Let_rec_symbol (_, program)
-    | Initialize_symbol (_, _, _, program) -> loop program
+    | Initialize_symbol (_, _, _, _, program) -> loop program
     | End root ->
       root
   in
diff --git a/middle_end/flambda/flambda_utils.mli b/middle_end/flambda/flambda_utils.mli
index b47cd04a56cb..7230aef5cf39 100644
--- a/middle_end/flambda/flambda_utils.mli
+++ b/middle_end/flambda/flambda_utils.mli
@@ -99,7 +99,7 @@ val name_expr_from_var
 
 val initialize_symbols
    : Flambda.program
-  -> (Symbol.t * Tag.t * Flambda.t list) list
+  -> (Symbol.t * Tag.t * Flambda.t list * Block_desc.t) list
 
 val imported_symbols : Flambda.program -> Symbol.Set.t
 
diff --git a/middle_end/flambda/import_approx.ml b/middle_end/flambda/import_approx.ml
index f5c004aa6bba..a7aebd68352e 100644
--- a/middle_end/flambda/import_approx.ml
+++ b/middle_end/flambda/import_approx.ml
@@ -147,8 +147,8 @@ let rec import_ex ex =
       in
       A.value_string size contents
     | Value_mutable_block _ -> A.value_unknown Other
-    | Value_block (tag, fields) ->
-      A.value_block tag (Array.map import_approx fields)
+    | Value_block (tag, fields, desc) ->
+      A.value_block tag (Array.map import_approx fields) desc
     | Value_closure { closure_id;
           set_of_closures =
             { set_of_closures_id; bound_vars; free_vars; aliased_symbol } } ->
diff --git a/middle_end/flambda/inconstant_idents.ml b/middle_end/flambda/inconstant_idents.ml
index 9877a1729d17..42b67f41abba 100644
--- a/middle_end/flambda/inconstant_idents.ml
+++ b/middle_end/flambda/inconstant_idents.ml
@@ -447,7 +447,7 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
     let rec loop (program : Flambda.program_body) =
       match program with
       | End _ -> ()
-      | Initialize_symbol (symbol,_tag,fields,program) ->
+      | Initialize_symbol (symbol,_tag,fields,_desc,program) ->
         List.iteri (fun i field ->
             mark_loop ~toplevel:true
               [Symbol symbol; Symbol_field (symbol,i)] field)
diff --git a/middle_end/flambda/initialize_symbol_to_let_symbol.ml b/middle_end/flambda/initialize_symbol_to_let_symbol.ml
index 31246b0d46ba..92923d29fafe 100644
--- a/middle_end/flambda/initialize_symbol_to_let_symbol.ml
+++ b/middle_end/flambda/initialize_symbol_to_let_symbol.ml
@@ -32,15 +32,15 @@ let constant_field (expr:Flambda.t)
 
 let rec loop (program : Flambda.program_body) : Flambda.program_body =
   match program with
-  | Initialize_symbol (symbol, tag, fields, program) ->
+  | Initialize_symbol (symbol, tag, fields, desc, program) ->
     let constant_fields = List.map constant_field fields in
     begin
       match Misc.Stdlib.List.some_if_all_elements_are_some constant_fields
     with
     | None ->
-      Initialize_symbol (symbol, tag, fields, loop program)
+      Initialize_symbol (symbol, tag, fields, desc, loop program)
     | Some fields ->
-      Let_symbol (symbol, Block (tag, fields), loop program)
+      Let_symbol (symbol, Block (tag, fields, desc), loop program)
     end
   | Let_symbol (symbol, const, program) ->
     Let_symbol (symbol, const, loop program)
diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml
index 308602b1da2b..4ee1bd0c79ac 100644
--- a/middle_end/flambda/inline_and_simplify.ml
+++ b/middle_end/flambda/inline_and_simplify.ml
@@ -1420,7 +1420,7 @@ let constant_defining_value_approx
   match constant_defining_value with
   | Allocated_const const ->
     approx_for_allocated_const const
-  | Block (tag, fields) ->
+  | Block (tag, fields, desc) ->
     let fields =
       List.map
         (function
@@ -1432,7 +1432,7 @@ let constant_defining_value_approx
           | Flambda.Const cst -> simplify_const cst)
         fields
     in
-    A.value_block tag (Array.of_list fields)
+    A.value_block tag (Array.of_list fields) desc
   | Set_of_closures { function_decls; free_vars; specialised_args } ->
     (* At toplevel, there is no freshening currently happening (this
        cannot be the body of a currently inlined function), so we can
@@ -1523,14 +1523,14 @@ let simplify_constant_defining_value
     (* No simplifications are possible for [Allocated_const] or [Block]. *)
     | Allocated_const const ->
       r, constant_defining_value, approx_for_allocated_const const
-    | Block (tag, fields) ->
+    | Block (tag, fields, desc) ->
       let fields = List.map
           (function
             | Flambda.Symbol sym -> E.find_symbol_exn env sym
             | Flambda.Const cst -> simplify_const cst)
           fields
       in
-      r, constant_defining_value, A.value_block tag (Array.of_list fields)
+      r, constant_defining_value, A.value_block tag (Array.of_list fields) desc
     | Set_of_closures set_of_closures ->
       if not (Variable.Map.is_empty set_of_closures.free_vars) then begin
         Misc.fatal_errorf "Set of closures bound by [Let_symbol] is not \
@@ -1607,14 +1607,14 @@ let rec simplify_program_body env r (program : Flambda.program_body)
     let env = E.add_symbol env symbol approx in
     let program, r = simplify_program_body env r program in
     Let_symbol (symbol, constant_defining_value, program), r
-  | Initialize_symbol (symbol, tag, fields, program) ->
+  | Initialize_symbol (symbol, tag, fields, desc, program) ->
     let fields, approxs, r = simplify_list env r fields in
     let approx =
-      A.augment_with_symbol (A.value_block tag (Array.of_list approxs)) symbol
+      A.augment_with_symbol (A.value_block tag (Array.of_list approxs) desc) symbol
     in
     let env = E.add_symbol env symbol approx in
     let program, r = simplify_program_body env r program in
-    Initialize_symbol (symbol, tag, fields, program), r
+    Initialize_symbol (symbol, tag, fields, desc, program), r
   | Effect (expr, program) ->
     let expr, r = simplify env r expr in
     let program, r = simplify_program_body env r program in
@@ -1653,6 +1653,7 @@ let add_predef_exns_to_environment ~env ~backend =
           [| A.value_string (String.length name) (Some name);
              A.value_unknown Other;
           |]
+          Block_desc.empty
       in
       E.add_symbol env symbol (A.augment_with_symbol approx symbol))
     env
diff --git a/middle_end/flambda/lift_constants.ml b/middle_end/flambda/lift_constants.ml
index 6ebff1007344..0e71b7b51fa6 100644
--- a/middle_end/flambda/lift_constants.ml
+++ b/middle_end/flambda/lift_constants.ml
@@ -58,9 +58,9 @@ let assign_symbols_and_collect_constant_definitions
         (* [Inconstant_idents] always marks these expressions as
            inconstant, so we should never get here. *)
         assert false
-      | Prim (Pmakeblock (tag, _, _value_kind, _bdesc), fields, _) ->
+      | Prim (Pmakeblock (tag, _, _value_kind, desc), fields, _) ->
         assign_symbol ();
-        record_definition (AA.Block (Tag.create_exn tag, fields))
+        record_definition (AA.Block (Tag.create_exn tag, fields, desc))
       | Read_symbol_field (symbol, field) ->
         record_definition (AA.Symbol_field (symbol, field))
       | Set_of_closures (
@@ -130,7 +130,7 @@ let assign_symbols_and_collect_constant_definitions
         decls;
       collect_let_and_initialize_symbols program
     | Effect (_, program) -> collect_let_and_initialize_symbols program
-    | Initialize_symbol (symbol,_tag,fields,program) ->
+    | Initialize_symbol (symbol,_tag,fields,_desc,program) ->
       collect_let_and_initialize_symbols program;
       let fields = List.map tail_variable fields in
       Symbol.Tbl.add initialize_symbol_to_definition_tbl symbol fields
@@ -331,11 +331,12 @@ let translate_definition_and_resolve_alias inconstants
     Some (Flambda.Allocated_const const)
   in
   match definition with
-  | Block (tag, fields) ->
+  | Block (tag, fields, desc) ->
     Some (Flambda.Block (tag,
       List.map (resolve_variable aliases var_to_symbol_tbl
           var_to_definition_tbl)
-        fields))
+        fields,
+      desc))
   | Allocated_const (Normal const) -> Some (Flambda.Allocated_const const)
   | Allocated_const (Duplicate_array (Pfloatarray, mutability, var)) ->
     (* CR-someday mshinwell: This next section could do with cleanup.
@@ -524,7 +525,7 @@ let constant_dependencies ~backend:_
         (const : Flambda.constant_defining_value) =
   match const with
   | Allocated_const _ -> Symbol.Set.empty
-  | Block (_, fields) ->
+  | Block (_, fields, _) ->
     let symbol_fields =
       List.filter_map
         (function
@@ -542,7 +543,7 @@ module Symbol_SCC = Strongly_connected_components.Make (Symbol)
 
 let program_graph ~backend imported_symbols symbol_to_constant
     (initialize_symbol_tbl :
-      (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t)
+      (Tag.t * Flambda.t list * Block_desc.t * Symbol.t option) Symbol.Tbl.t)
     (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) =
   let expression_symbol_dependencies expr = Flambda.free_symbols expr in
   let graph_with_only_constant_parts =
@@ -552,7 +553,7 @@ let program_graph ~backend imported_symbols symbol_to_constant
       symbol_to_constant
   in
   let graph_with_initialisation =
-    Symbol.Tbl.fold (fun sym (_tag, fields, previous) ->
+    Symbol.Tbl.fold (fun sym (_tag, fields, _desc, previous) ->
         let order_dep =
           match previous with
           | None -> Symbol.Set.empty
@@ -590,7 +591,7 @@ let program_graph ~backend imported_symbols symbol_to_constant
 (* rebuilding the program *)
 let add_definition_of_symbol constant_definitions
     (initialize_symbol_tbl :
-      (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t)
+      (Tag.t * Flambda.t list * Block_desc.t * Symbol.t option) Symbol.Tbl.t)
     (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t)
     (program : Flambda.program_body) component : Flambda.program_body =
   let symbol_declaration sym =
@@ -607,8 +608,8 @@ let add_definition_of_symbol constant_definitions
     Let_rec_symbol (l, program)
   | Symbol_SCC.No_loop sym ->
     match Symbol.Tbl.find initialize_symbol_tbl sym with
-    | (tag, fields, _previous) ->
-      Initialize_symbol (sym, tag, fields, program)
+    | (tag, fields, desc, _previous) ->
+      Initialize_symbol (sym, tag, fields, desc, program)
     | exception Not_found ->
       match Symbol.Tbl.find effect_tbl sym with
       | (expr, _previous) ->
@@ -784,7 +785,7 @@ let program_symbols ~backend (program : Flambda.program) =
           Symbol.Tbl.add symbol_definition_tbl symbol def)
         defs;
       loop program previous_effect
-    | Flambda.Initialize_symbol (symbol, tag, fields, program) ->
+    | Flambda.Initialize_symbol (symbol, tag, fields, desc, program) ->
       (* previous_effect is used to keep the order of initialize and effect
          values. Their effects order must be kept ordered.
          it is used as an extra dependency when sorting the symbols. *)
@@ -792,7 +793,7 @@ let program_symbols ~backend (program : Flambda.program) =
          drop this dependency
          mshinwell: deferred CR *)
       Symbol.Tbl.add initialize_symbol_tbl symbol
-        (tag, fields, previous_effect);
+        (tag, fields, desc, previous_effect);
       loop program (Some symbol)
     | Flambda.Effect (expr, program) ->
       (* Used to ensure that effects are correctly ordered *)
@@ -811,7 +812,7 @@ let replace_definitions_in_initialize_symbol_and_effects
     (var_to_definition_tbl :
       Alias_analysis.constant_defining_value Variable.Tbl.t)
     (initialize_symbol_tbl :
-      (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t)
+      (Tag.t * Flambda.t list * Block_desc.t * Symbol.t option) Symbol.Tbl.t)
     (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) =
   let rewrite_expr expr =
     Flambda_iterators.map_all_immutable_let_and_let_rec_bindings expr
@@ -839,9 +840,10 @@ let replace_definitions_in_initialize_symbol_and_effects
   (* This is safe because we only [replace] the current key during
      iteration (cf. https://github.com/ocaml/ocaml/pull/337) *)
   Symbol.Tbl.iter
-    (fun symbol (tag, fields, previous) ->
+    (fun symbol (tag, fields, desc, previous) ->
       let fields = List.map rewrite_expr fields in
-      Symbol.Tbl.replace initialize_symbol_tbl symbol (tag, fields, previous))
+      Symbol.Tbl.replace initialize_symbol_tbl
+        symbol (tag, fields, desc, previous))
     initialize_symbol_tbl;
   Symbol.Tbl.iter
     (fun symbol (expr, previous) ->
@@ -999,9 +1001,9 @@ let lift_constants (program : Flambda.program) ~backend =
     Symbol.Tbl.map effect_tbl (fun (eff, dep) -> rewrite_expr eff, dep)
   in
   let initialize_symbol_tbl =
-    Symbol.Tbl.map initialize_symbol_tbl (fun (tag, fields, dep) ->
+    Symbol.Tbl.map initialize_symbol_tbl (fun (tag, fields, desc, dep) ->
       let fields = List.map rewrite_expr fields in
-      tag, fields, dep)
+      tag, fields, desc, dep)
   in
   let imported_symbols = Flambda_utils.imported_symbols program in
   let components =
diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.ml b/middle_end/flambda/lift_let_to_initialize_symbol.ml
index c019b017a94d..86771a722c56 100644
--- a/middle_end/flambda/lift_let_to_initialize_symbol.ml
+++ b/middle_end/flambda/lift_let_to_initialize_symbol.ml
@@ -18,7 +18,7 @@
 open! Int_replace_polymorphic_compare
 
 type ('a, 'b) kind =
-  | Initialisation of (Symbol.t * Tag.t * Flambda.t list)
+  | Initialisation of (Symbol.t * Tag.t * Flambda.t list * Block_desc.t)
   | Effect of 'b
 
 let should_copy (named:Flambda.named) =
@@ -28,7 +28,7 @@ let should_copy (named:Flambda.named) =
 
 type extracted =
   | Expr of Variable.t * Flambda.t
-  | Block of Variable.t * Tag.t * Variable.t list
+  | Block of Variable.t * Tag.t * Variable.t list * Block_desc.t
 
 type accumulated = {
   copied_lets : (Variable.t * Flambda.named) list;
@@ -65,7 +65,7 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets
     let extracted =
       let renamed = Variable.rename var in
       match named with
-      | Prim (Pmakeblock (tag, Asttypes.Immutable, _value_kind, _bdesc), args, _dbg) ->
+      | Prim (Pmakeblock (tag, Asttypes.Immutable, _value_kind, desc), args, _dbg) ->
         let tag = Tag.create_exn tag in
         let args =
           List.map (fun v ->
@@ -73,7 +73,7 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets
               with Not_found -> v)
             args
         in
-        Block (var, tag, args)
+        Block (var, tag, args, desc)
       | named ->
         let expr =
           Flambda_utils.toplevel_substitution substitution
@@ -121,7 +121,7 @@ let rebuild (used_variables:Variable.Set.t) (accumulated:accumulated) =
   let accumulated_extracted_lets =
     List.map (fun decl ->
         match decl with
-        | Block (var, _, _) | Expr (var, _) ->
+        | Block (var, _, _, _) | Expr (var, _) ->
           Symbol.of_variable (Variable.rename var), decl)
       accumulated.extracted_lets
   in
@@ -139,7 +139,7 @@ let rebuild (used_variables:Variable.Set.t) (accumulated:accumulated) =
          field of the field 0 of the symbol. *)
     List.fold_left (fun map (symbol, decl) ->
         match decl with
-        | Block (var, _tag, _fields) ->
+        | Block (var, _tag, _fields, _desc) ->
           Variable.Map.add var (symbol, []) map
         | Expr (var, _expr) ->
           Variable.Map.add var (symbol, [0]) map)
@@ -157,17 +157,18 @@ let rebuild (used_variables:Variable.Set.t) (accumulated:accumulated) =
             Initialisation
               (symbol,
                Tag.create_exn 0,
-               [expr])
+               [expr],
+               Block_desc.empty)
           else
             Effect expr
-        | Block (_var, tag, fields) ->
+        | Block (_var, tag, fields, desc) ->
           let fields =
             List.map (fun var ->
                 rebuild_expr ~extracted_definitions ~copied_definitions
                   ~substitute:true (Var var))
               fields
           in
-          Initialisation (symbol, tag, fields))
+          Initialisation (symbol, tag, fields, desc))
       accumulated_extracted_lets
   in
   let terminator =
@@ -192,8 +193,8 @@ let introduce_symbols expr =
 let add_extracted introduced program =
   List.fold_right (fun extracted program ->
       match extracted with
-      | Initialisation (symbol, tag, def) ->
-        Flambda.Initialize_symbol (symbol, tag, def, program)
+      | Initialisation (symbol, tag, def, desc) ->
+        Flambda.Initialize_symbol (symbol, tag, def, desc, program)
       | Effect eff ->
         Flambda.Effect (eff, program))
     introduced program
@@ -209,18 +210,18 @@ let rec split_program (program : Flambda.program_body) : Flambda.program_body =
     let program = split_program program in
     let introduced, expr = introduce_symbols expr in
     add_extracted introduced (Flambda.Effect (expr, program))
-  | Initialize_symbol (symbol, tag, ((_::_::_) as fields), program) ->
+  | Initialize_symbol (symbol, tag, ((_::_::_) as fields), desc, program) ->
     (* CR-someday pchambart: currently the only initialize_symbol with more
        than 1 field is the module block. This could evolve, in that case
        this pattern should be handled properly. *)
-    Initialize_symbol (symbol, tag, fields, split_program program)
-  | Initialize_symbol (sym, tag, [], program) ->
-    Let_symbol (sym, Block (tag, []), split_program program)
-  | Initialize_symbol (symbol, tag, [field], program) ->
+    Initialize_symbol (symbol, tag, fields, desc, split_program program)
+  | Initialize_symbol (sym, tag, [], desc, program) ->
+    Let_symbol (sym, Block (tag, [], desc), split_program program)
+  | Initialize_symbol (symbol, tag, [field], desc, program) ->
     let program = split_program program in
     let introduced, field = introduce_symbols field in
     add_extracted introduced
-      (Flambda.Initialize_symbol (symbol, tag, [field], program))
+      (Flambda.Initialize_symbol (symbol, tag, [field], desc, program))
 
 let lift ~backend:_ (program : Flambda.program) =
   { program with
diff --git a/middle_end/flambda/remove_unused_program_constructs.ml b/middle_end/flambda/remove_unused_program_constructs.ml
index 468223dcfa11..821e9f22b3e9 100644
--- a/middle_end/flambda/remove_unused_program_constructs.ml
+++ b/middle_end/flambda/remove_unused_program_constructs.ml
@@ -26,7 +26,7 @@ let constant_dependencies (const:Flambda.constant_defining_value) =
   in
   match const with
   | Allocated_const _ -> Symbol.Set.empty
-  | Block (_, fields) ->
+  | Block (_, fields, _) ->
     let symbol_fields =
       List.filter_map (function
           | (Symbol s : Flambda.constant_defining_value_block_field) ->
@@ -74,7 +74,7 @@ let rec loop (program : Flambda.program_body)
       | [] -> program, dep
       | _ -> Let_rec_symbol (defs, program), dep
     end
-  | Initialize_symbol (sym, tag, fields, program) ->
+  | Initialize_symbol (sym, tag, fields, desc, program) ->
     let program, dep = loop program in
     if Symbol.Set.mem sym dep then
       let dep =
@@ -82,7 +82,7 @@ let rec loop (program : Flambda.program_body)
             Symbol.Set.union dep (dependency field))
           dep fields
       in
-      Initialize_symbol (sym, tag, fields, program), dep
+      Initialize_symbol (sym, tag, fields, desc, program), dep
     else begin
       List.fold_left
         (fun (program, dep) field ->
diff --git a/middle_end/flambda/share_constants.ml b/middle_end/flambda/share_constants.ml
index 2bbd7134b8a2..000f1327e382 100644
--- a/middle_end/flambda/share_constants.ml
+++ b/middle_end/flambda/share_constants.ml
@@ -28,7 +28,7 @@ let update_constant_for_sharing sharing_symbol_tbl const
   in
   match (const:Flambda.constant_defining_value) with
   | Allocated_const _ -> const
-  | Block (tag, fields) ->
+  | Block (tag, fields, desc) ->
     let subst_field (field:Flambda.constant_defining_value_block_field) :
       Flambda.constant_defining_value_block_field =
       match field with
@@ -37,7 +37,7 @@ let update_constant_for_sharing sharing_symbol_tbl const
         Symbol (substitute_symbol sym)
     in
     let fields = List.map subst_field fields in
-    Block (tag, fields)
+    Block (tag, fields, desc)
   | Set_of_closures set_of_closures ->
     Set_of_closures (
       Flambda_iterators.map_symbols_on_set_of_closures
@@ -75,7 +75,7 @@ let rec end_symbol (program : Flambda.program_body) =
   | End symbol -> symbol
   | Let_symbol (_, _, program)
   | Let_rec_symbol (_, program)
-  | Initialize_symbol (_, _, _, program)
+  | Initialize_symbol (_, _, _, _, program)
   | Effect (_, program) ->
     end_symbol program
 
@@ -103,7 +103,7 @@ let share_constants (program : Flambda.program) =
           defs
       in
       Let_rec_symbol (defs, loop program)
-    | Initialize_symbol (symbol,tag,fields,program) ->
+    | Initialize_symbol (symbol,tag,fields,desc,program) ->
       let fields =
         List.map (fun field ->
             Flambda_iterators.map_symbols
@@ -113,7 +113,7 @@ let share_constants (program : Flambda.program) =
               field)
           fields
       in
-      Initialize_symbol (symbol,tag,fields,loop program)
+      Initialize_symbol (symbol,tag,fields,desc,loop program)
     | Effect (expr,program) ->
       let expr =
         Flambda_iterators.map_symbols
diff --git a/middle_end/flambda/simple_value_approx.ml b/middle_end/flambda/simple_value_approx.ml
index 88cd3a564b38..25380deb8446 100644
--- a/middle_end/flambda/simple_value_approx.ml
+++ b/middle_end/flambda/simple_value_approx.ml
@@ -45,7 +45,7 @@ type t = {
 }
 
 and descr =
-  | Value_block of Tag.t * t array
+  | Value_block of Tag.t * t array * Block_desc.t
   | Value_int of int
   | Value_char of char
   | Value_float of float option
@@ -171,10 +171,11 @@ let print_function_declarations ppf (fd : function_declarations) =
 let rec print_descr ppf = function
   | Value_int i -> Format.pp_print_int ppf i
   | Value_char c -> Format.fprintf ppf "%c" c
-  | Value_block (tag,fields) ->
+  | Value_block (tag,fields,desc) ->
     let p ppf fields =
       Array.iter (fun v -> Format.fprintf ppf "%a@ " print v) fields in
-    Format.fprintf ppf "[%i:@ @[<1>%a@]]" (Tag.to_int tag) p fields
+    Format.fprintf ppf "[%i:@ @[<1>%a@] (%a)]" (Tag.to_int tag) p fields
+      Block_desc.format desc
   | Value_unknown reason ->
     begin match reason with
     | Unresolved_value value ->
@@ -352,7 +353,7 @@ let value_set_of_closures ?set_of_closures_var value_set_of_closures =
     symbol = None;
   }
 
-let value_block t b = approx (Value_block (t, b))
+let value_block t b desc = approx (Value_block (t, b, desc))
 let value_extern ex = approx (Value_extern ex)
 let value_symbol sym =
   { (approx (Value_symbol sym)) with symbol = Some (sym, None) }
@@ -555,7 +556,7 @@ let warn_on_mutation t =
   if not !Clflags.flambda_invariant_checks then false
   else
     match t.descr with
-    | Value_block(_, fields) -> Array.length fields > 0
+    | Value_block(_, fields, _) -> Array.length fields > 0
     | Value_string { contents = Some _ }
     | Value_int _ | Value_char _
     | Value_set_of_closures _ | Value_float _ | Value_boxed_int _
@@ -570,7 +571,7 @@ type get_field_result =
 
 let get_field t ~field_index:i : get_field_result =
   match t.descr with
-  | Value_block (_tag, fields) ->
+  | Value_block (_tag, fields, _desc) ->
     if i >= 0 && i < Array.length fields then begin
       Ok fields.(i)
     end else begin
@@ -611,12 +612,12 @@ let get_field t ~field_index:i : get_field_result =
 
 type checked_approx_for_block =
   | Wrong
-  | Ok of Tag.t * t array
+  | Ok of Tag.t * t array * Block_desc.t
 
 let check_approx_for_block t =
   match t.descr with
-  | Value_block (tag, fields) ->
-    Ok (tag, fields)
+  | Value_block (tag, fields, desc) ->
+    Ok (tag, fields, desc)
   | Value_bottom
   | Value_int _ | Value_char _
   | Value_float_array _
@@ -677,12 +678,15 @@ let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with
   | Value_boxed_int (bi1, i1), Value_boxed_int (bi2, i2) when
       equal_boxed_int bi1 i1 bi2 i2 ->
       d1
-  | Value_block (tag1, a1), Value_block (tag2, a2)
+  | Value_block (tag1, a1, desc1), Value_block (tag2, a2, desc2)
     when Tag.compare tag1 tag2 = 0 && Array.length a1 = Array.length a2 ->
     let fields =
       Array.mapi (fun i v -> meet ~really_import_approx v a2.(i)) a1
     in
-    Value_block (tag1, fields)
+    let desc =
+      if Block_desc.compare desc1 desc2 = 0 then desc1 else Block_desc.empty
+    in
+    Value_block (tag1, fields, desc)
   | _ -> Value_unknown Other
 
 and meet ~really_import_approx a1 a2 =
@@ -912,7 +916,7 @@ let potentially_taken_block_switch_branch t tag =
     Can_be_taken
   | (Value_int _| Value_char _) ->
     Cannot_be_taken
-  | Value_block (block_tag, _) when Tag.to_int block_tag = tag ->
+  | Value_block (block_tag, _, _) when Tag.to_int block_tag = tag ->
     Must_be_taken
   | Value_float _ when tag = Obj.double_tag ->
     Must_be_taken
diff --git a/middle_end/flambda/simple_value_approx.mli b/middle_end/flambda/simple_value_approx.mli
index 7a371408c3b9..2cfcda0c58d3 100644
--- a/middle_end/flambda/simple_value_approx.mli
+++ b/middle_end/flambda/simple_value_approx.mli
@@ -121,7 +121,7 @@ type t = private {
 }
 
 and descr = private
-  | Value_block of Tag.t * t array
+  | Value_block of Tag.t * t array * Block_desc.t
   | Value_int of int
   | Value_char of char
   | Value_float of float option
@@ -248,7 +248,7 @@ val value_mutable_float_array : size:int -> t
 val value_immutable_float_array : t array -> t
 val value_string : int -> string option -> t
 val value_boxed_int : 'i boxed_int -> 'i -> t
-val value_block : Tag.t -> t array -> t
+val value_block : Tag.t -> t array -> Block_desc.t -> t
 val value_extern : Export_id.t -> t
 val value_symbol : Symbol.t -> t
 val value_bottom : t
@@ -383,7 +383,7 @@ val get_field : t -> field_index:int -> get_field_result
 
 type checked_approx_for_block =
   | Wrong
-  | Ok of Tag.t * t array
+  | Ok of Tag.t * t array * Block_desc.t
 
 (** Try to prove that a value with the given approximation may be used
     as a block. *)
diff --git a/middle_end/flambda/simplify_primitives.ml b/middle_end/flambda/simplify_primitives.ml
index 29a4fcce6741..c587a95e56b7 100644
--- a/middle_end/flambda/simplify_primitives.ml
+++ b/middle_end/flambda/simplify_primitives.ml
@@ -41,7 +41,7 @@ let phys_equal (approxs:A.t list) =
 let is_known_to_be_some_kind_of_int (arg:A.descr) =
   match arg with
   | Value_int _ | Value_char _ -> true
-  | Value_block (_, _) | Value_float _ | Value_set_of_closures _
+  | Value_block (_, _, _) | Value_float _ | Value_set_of_closures _
   | Value_closure _ | Value_string _ | Value_float_array _
   | A.Value_boxed_int _ | Value_unknown _ | Value_extern _
   | Value_symbol _ | Value_unresolved _ | Value_bottom -> false
@@ -59,7 +59,7 @@ let rec structurally_different (arg1:A.t) (arg2:A.t) =
   | (Value_int n1), (Value_int n2)
     when n1 <> n2 ->
     true
-  | Value_block (tag1, fields1), Value_block (tag2, fields2) ->
+  | Value_block (tag1, fields1, _desc1), Value_block (tag2, fields2, _desc2) ->
     not (Tag.equal tag1 tag2)
     || (Array.length fields1 <> Array.length fields2)
     || Misc.Stdlib.Array.exists2 structurally_different fields1 fields2
@@ -108,7 +108,7 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs)
     : Flambda.named * A.t * Inlining_cost.Benefit.t =
   let fpc = !Clflags.float_const_prop in
   match p with
-  | Pmakeblock(tag_int, Asttypes.Immutable, shape, _bdesc) ->
+  | Pmakeblock(tag_int, Asttypes.Immutable, shape, desc) ->
     let tag = Tag.create_exn tag_int in
     let shape = match shape with
       | None -> List.map (fun _ -> Lambda.Pgenval) args
@@ -116,14 +116,14 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs)
     in
     let approxs = List.map2 A.augment_with_kind approxs shape in
     let shape = List.map2 A.augment_kind_with_approx approxs shape in
-    Prim (Pmakeblock(tag_int, Asttypes.Immutable, Some shape, _bdesc), args, dbg),
-    A.value_block tag (Array.of_list approxs), C.Benefit.zero
+    Prim (Pmakeblock(tag_int, Asttypes.Immutable, Some shape, desc), args, dbg),
+    A.value_block tag (Array.of_list approxs) desc, C.Benefit.zero
   | Praise _ ->
     expr, A.value_bottom, C.Benefit.zero
-  | Pmakearray(_, _, _bdesc) when is_empty approxs ->
+  | Pmakearray(_, _, desc) when is_empty approxs ->
     let shape = Some [] in
-    Prim (Pmakeblock(0, Asttypes.Immutable, shape, _bdesc), [], dbg),
-    A.value_block (Tag.create_exn 0) [||], C.Benefit.zero
+    Prim (Pmakeblock(0, Asttypes.Immutable, shape, desc), [], dbg),
+    A.value_block (Tag.create_exn 0) [||] desc, C.Benefit.zero
   | Pmakearray (Pfloatarray, Mutable, _bdesc) ->
       let approx =
         A.value_mutable_float_array ~size:(List.length args)
diff --git a/middle_end/flambda/traverse_for_exported_symbols.ml b/middle_end/flambda/traverse_for_exported_symbols.ml
index 1b7ce57f54a1..648263f2cdeb 100644
--- a/middle_end/flambda/traverse_for_exported_symbols.ml
+++ b/middle_end/flambda/traverse_for_exported_symbols.ml
@@ -191,7 +191,7 @@ let traverse
       | Q_export_id export_id ->
         begin match Export_id.Map.find export_id values with
         | exception Not_found -> ()
-        | Value_block (_, approxes) ->
+        | Value_block (_, approxes, _) ->
           Array.iter process_approx approxes
         | Value_closure value_closure ->
           process_value_set_of_closures value_closure.set_of_closures