Flambda support for Introcaml

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 = {

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 = {

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

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

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

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

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 =

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} ->

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

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;

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
 

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

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

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