flambda-backend: Port PR1202 and PR1205 to the ocaml/ subtree (#1211)

Author: mshinwell

asmcomp/cmm_helpers.ml

@@ -666,11 +666,14 @@ let field_address ptr n dbg =
   then ptr
   else Cop(Cadda, [ptr; Cconst_int(n * size_addr, dbg)], dbg)
 
+let get_field_gen_given_memory_chunk memory_chunk mut ptr n dbg =
+  Cop (Cload (memory_chunk, mut), [field_address ptr n dbg], dbg)
+
 let get_field_gen mut ptr n dbg =
-  Cop(Cload (Word_val, mut), [field_address ptr n dbg], dbg)
+  get_field_gen_given_memory_chunk Word_val mut ptr n dbg
 
 let get_field_codepointer mut ptr n dbg =
-  Cop (Cload (Word_int, mut), [field_address ptr n dbg], dbg)
+  get_field_gen_given_memory_chunk Word_int mut ptr n dbg
 
 let set_field ptr n newval init dbg =
   Cop(Cstore (Word_val, init), [field_address ptr n dbg; newval], dbg)

asmcomp/cmm_helpers.mli

@@ -194,10 +194,20 @@ val remove_unit : expression -> expression
 val field_address : expression -> int -> Debuginfo.t -> expression
 
 (** [get_field_gen mut ptr n dbg] returns an expression for the access to the
-    [n]th field of the block pointed to by [ptr] *)
+    [n]th field of the block pointed to by [ptr].  The [memory_chunk] used is
+    always [Word_val]. *)
 val get_field_gen :
   Asttypes.mutable_flag -> expression -> int -> Debuginfo.t -> expression
 
+(** Like [get_field_gen] but allows use of a different [memory_chunk]. *)
+val get_field_gen_given_memory_chunk :
+  Cmm.memory_chunk ->
+  Asttypes.mutable_flag ->
+  expression ->
+  int ->
+  Debuginfo.t ->
+  expression
+
 (** [set_field ptr n newval init dbg] returns an expression for setting the
     [n]th field of the block pointed to by [ptr] to [newval] *)
 val set_field :

asmcomp/cmmgen.ml

@@ -117,9 +117,20 @@ let mut_from_env env ptr =
       else Asttypes.Mutable
     | _ -> Asttypes.Mutable
 
-let get_field env ptr n dbg =
+let get_field env layout ptr n dbg =
   let mut = mut_from_env env ptr in
-  get_field_gen mut ptr n dbg
+  let memory_chunk =
+    match layout with
+    | Pvalue Pintval | Punboxed_int _ -> Word_int
+    | Pvalue _ -> Word_val
+    | Punboxed_float -> Double
+    | Ptop ->
+        Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg
+    | Pbottom ->
+        Misc.fatal_errorf "get_field with Pbottom: %a" Debuginfo.print_compact
+          dbg
+  in
+  get_field_gen_given_memory_chunk memory_chunk mut ptr n dbg
 
 type rhs_kind =
   | RHS_block of Lambda.alloc_mode * int
@@ -869,8 +880,8 @@ and transl_prim_1 env p arg dbg =
     Popaque ->
       opaque (transl env arg) dbg
   (* Heap operations *)
-  | Pfield n ->
-      get_field env (transl env arg) n dbg
+  | Pfield (n, layout) ->
+      get_field env layout (transl env arg) n dbg
   | Pfloatfield (n,mode) ->
       let ptr = transl env arg in
       box_float dbg mode (floatfield n ptr dbg)

middle_end/clambda_primitives.ml

@@ -36,7 +36,7 @@ type primitive =
   | Pread_symbol of string
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape * alloc_mode
-  | Pfield of int
+  | Pfield of int * layout
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment

middle_end/clambda_primitives.mli

@@ -36,7 +36,7 @@ type primitive =
   | Pread_symbol of string
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape * alloc_mode
-  | Pfield of int
+  | Pfield of int * layout
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment

middle_end/closure/closure.ml

@@ -52,9 +52,9 @@ let rec split_list n l =
 
 let rec add_to_closure_env env_param pos cenv = function
     [] -> cenv
-  | id :: rem ->
+  | (id, kind) :: rem ->
       V.Map.add id
-        (Uprim(P.Pfield pos, [Uvar env_param], Debuginfo.none))
+        (Uprim(P.Pfield (pos, kind), [Uvar env_param], Debuginfo.none))
           (add_to_closure_env env_param (pos+1) cenv rem)
 
 let is_gc_ignorable kind =
@@ -67,7 +67,12 @@ let is_gc_ignorable kind =
   | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _) -> false
 
 let split_closure_fv kinds fv =
-  List.partition (fun id -> is_gc_ignorable (V.Map.find id kinds)) fv
+  List.fold_right (fun id (not_scanned, scanned) ->
+      let kind = V.Map.find id kinds in
+      if is_gc_ignorable kind
+      then ((id, kind) :: not_scanned, scanned)
+      else (not_scanned, (id, kind)::scanned))
+    fv ([], [])
 
 (* Auxiliary for accessing globals.  We change the name of the global
    to the name of the corresponding asm symbol.  This is done here
@@ -532,10 +537,10 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
         (Uprim(p, args, dbg), Value_tuple (mode, Array.of_list approxs))
       end
   (* Field access *)
-  | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]
+  | Pfield (n, _), _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]
     when n < List.length l ->
       make_const (List.nth l n)
-  | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
+  | Pfield (n, _), [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
     when n < List.length ul ->
       (* This case is particularly useful for removing allocations
          for optional parameters *)
@@ -943,7 +948,7 @@ let check_constant_result ulam approx =
           let glb =
             Uprim(P.Pread_symbol id, [], Debuginfo.none)
           in
-          Uprim(P.Pfield i, [glb], Debuginfo.none), approx
+          Uprim(P.Pfield (i, Lambda.layout_any_value), [glb], Debuginfo.none), approx
       end
   | _ -> (ulam, approx)
 
@@ -1308,7 +1313,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env)
   | Lprim(Pfield (n, _), [lam], loc) ->
       let (ulam, approx) = close env lam in
       let dbg = Debuginfo.from_location loc in
-      check_constant_result (Uprim(P.Pfield n, [ulam], dbg))
+      check_constant_result (Uprim(P.Pfield (n, Lambda.layout_any_value), [ulam], dbg))
                             (field_approx n approx)
   | Lprim(Psetfield(n, is_ptr, init),
           [Lprim(Pgetglobal cu, [], _); lam], loc) ->
@@ -1647,9 +1652,9 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_
     if !useless_env then [], [] else not_scanned_fv, scanned_fv in
   let env = { backend; fenv; cenv; mutable_vars; kinds; catch_env } in
   (Uclosure {
-      functions = clos ;
-      not_scanned_slots = List.map (close_var env) not_scanned_fv ;
-      scanned_slots = List.map (close_var env) scanned_fv
+      functions = clos;
+      not_scanned_slots = List.map (fun (id, _kind) -> close_var env id) not_scanned_fv;
+      scanned_slots = List.map (fun (id, _kind) -> close_var env id) scanned_fv
     },
    infos)
 

middle_end/convert_primitives.ml

@@ -28,7 +28,7 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
       Pmakeblock (tag, mutability, shape, mode)
   | Pmakefloatblock (mutability, mode) ->
       Pmakearray (Pfloatarray, mutability, mode)
-  | Pfield (field, _) -> Pfield field
+  | Pfield (field, _sem) -> Pfield (field, Pvalue Pgenval)
   | Pfield_computed _sem -> Pfield_computed
   | Psetfield (field, imm_or_pointer, init_or_assign) ->
       Psetfield (field, imm_or_pointer, init_or_assign)

middle_end/flambda/build_export_info.ml

@@ -290,7 +290,7 @@ and descr_of_named (env : Env.t) (named : Flambda.named)
       Value_block (Tag.create_exn tag, Array.of_list approxs)
     in
     Value_id (Env.new_descr env descr)
-  | Prim (Pfield i, [arg], _) ->
+  | 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)
     | _ -> Value_unknown

middle_end/flambda/closure_conversion.ml

@@ -96,7 +96,7 @@ let tupled_function_call_stub original_params unboxed_version ~closure_bound_var
   let _, body =
     List.fold_left (fun (pos, body) param ->
         let lam : Flambda.named =
-          Prim (Pfield pos, [tuple_param_var], Debuginfo.none)
+          Prim (Pfield (pos, Pvalue Pgenval), [tuple_param_var], Debuginfo.none)
         in
         pos + 1, Flambda.create_let param lam body)
       (0, call) params
@@ -733,9 +733,9 @@ let lambda_to_flambda ~backend ~compilation_unit ~size lam
       Flambda.create_let
         sym_v (Symbol block_symbol)
          (Flambda.create_let result_v
-            (Prim (Pfield 0, [sym_v], Debuginfo.none))
+            (Prim (Pfield (0, Pvalue Pgenval), [sym_v], Debuginfo.none))
             (Flambda.create_let value_v
-              (Prim (Pfield pos, [result_v], Debuginfo.none))
+              (Prim (Pfield (pos, Pvalue Pgenval), [result_v], Debuginfo.none))
               (Var value_v))))
   in
   let module_initializer : Flambda.program_body =

middle_end/flambda/extract_projections.ml

@@ -125,7 +125,7 @@ let rec analyse_expr ~which_variables expr =
         when Variable.Map.mem move.closure which_variables ->
       projections :=
         Projection.Set.add (Move_within_set_of_closures move) !projections
-    | Prim (Pfield field_index, [var], _dbg)
+    | Prim (Pfield (field_index, Pvalue _), [var], _dbg)
         when Variable.Map.mem var which_variables ->
       projections :=
         Projection.Set.add (Field (field_index, var)) !projections

middle_end/flambda/flambda_to_clambda.ml

@@ -469,7 +469,8 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda * Lambd
         Flambda.print_named named
     end
   | Read_symbol_field (symbol, field) ->
-    Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none),
+    Uprim (Pfield (field, Pvalue Pgenval),
+      [to_clambda_symbol env symbol], Debuginfo.none),
     Lambda.layout_any_value
   | Set_of_closures set_of_closures ->
     to_clambda_set_of_closures t env set_of_closures,
@@ -502,14 +503,20 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda * Lambd
     let fun_offset = get_fun_offset t closure_id in
     let var_offset = get_fv_offset t var in
     let pos = var_offset - fun_offset in
-    Uprim (Pfield pos,
+    Uprim (Pfield (pos, kind),
       [check_field t (check_closure t ulam (Expr (Var closure)))
          pos (Some named)],
       Debuginfo.none),
     kind
-  | Prim (Pfield index, [block], dbg) ->
+  | Prim (Pfield (index, layout), [block], dbg) ->
+    begin match layout with
+      | Pvalue _ -> ()
+      | _ ->
+        Misc.fatal_errorf "Pfield can only be of layout value %a"
+          Flambda.print_named named
+    end;
     let block, _block_layout = subst_var env block in
-    Uprim (Pfield index, [check_field t block index None], dbg),
+    Uprim (Pfield (index, layout), [check_field t block index None], dbg),
     Lambda.layout_field
   | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
     let block, _block_layout = subst_var env block in
@@ -649,7 +656,7 @@ and to_clambda_set_of_closures t env
         in
         let pos = var_offset - fun_offset in
         Env.add_subst env id
-          (Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none))
+          (Uprim (Pfield (pos, spec_to.kind), [Clambda.Uvar env_var], Debuginfo.none))
           spec_to.kind
       in
       let env = Variable.Map.fold add_env_free_variable free_vars env in

middle_end/flambda/flambda_utils.ml

@@ -567,7 +567,7 @@ let substitute_read_symbol_field_for_variables
           Expr (
             Flambda.create_let block (make_named t)
               (Flambda.create_let field
-                 (Prim (Pfield h, [block], Debuginfo.none))
+                 (Prim (Pfield (h, Pvalue Pgenval), [block], Debuginfo.none))
                  (Var field)))
     in
     Flambda.create_let fresh_var (make_named path) expr
@@ -930,7 +930,7 @@ let projection_to_named (projection : Projection.t) : Flambda.named =
   | Project_closure project_closure -> Project_closure project_closure
   | Move_within_set_of_closures move -> Move_within_set_of_closures move
   | Field (field_index, var) ->
-    Prim (Pfield field_index, [var], Debuginfo.none)
+    Prim (Pfield (field_index, Pvalue Pgenval), [var], Debuginfo.none)
 
 type specialised_to_same_as =
   | Not_specialised

middle_end/flambda/inline_and_simplify.ml

@@ -1071,7 +1071,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
       in
       begin match prim, args, args_approxs with
       (* CR-someday mshinwell: Optimise [Pfield_computed]. *)
-      | Pfield field_index, [arg], [arg_approx] ->
+      | Pfield (field_index, _), [arg], [arg_approx] ->
         let projection : Projection.t = Field (field_index, arg) in
         begin match E.find_projection env ~projection with
         | Some var ->

middle_end/flambda/lift_constants.ml

@@ -84,8 +84,12 @@ let assign_symbols_and_collect_constant_definitions
       | Project_closure ({ closure_id } as project_closure) ->
         assign_existing_symbol (Symbol_utils.Flambda.for_closure closure_id);
         record_definition (AA.Project_closure project_closure)
-      | Prim (Pfield index, [block], _) ->
+      | Prim (Pfield (index, Pvalue _), [block], _) ->
         record_definition (AA.Field (block, index))
+      | Prim (Pfield (_, _), [_], _) ->
+        Misc.fatal_errorf "[Pfield] with kind not value is not expected to be\
+                           constant: @.%a@."
+          Flambda.print_named named
       | Prim (Pfield _, _, _) ->
         Misc.fatal_errorf "[Pfield] with the wrong number of arguments"
           Flambda.print_named named

middle_end/flambda/ref_to_variables.ml

@@ -159,7 +159,7 @@ let eliminate_ref_of_expr flam =
         flam
     and aux_named (named : Flambda.named) : Flambda.named =
       match named with
-      | Prim(Pfield field, [v], _)
+      | Prim(Pfield (field, _), [v], _)
         when convertible_variable v ->
         (match get_variable v field with
          | None -> Expr Proved_unreachable

middle_end/printclambda_primitives.ml

@@ -72,7 +72,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
       in
       let name = "make" ^ mode ^ mut in
       fprintf ppf "%s %i%a" name tag Printlambda.block_shape shape
-  | Pfield n -> fprintf ppf "field %i" n
+  | Pfield (n, layout) -> fprintf ppf "field%a %i" Printlambda.layout layout n
   | Pfield_computed -> fprintf ppf "field_computed"
   | Psetfield(n, ptr, init) ->
       let instr =