Fix fatal error when compiling objects with Flambda (ocaml#965)

Changes

@@ -338,6 +338,10 @@ Next version (4.05.0):
 
 - PR#7427, GPR#959: Don't delete let bodies in Cmmgen (Mark Shinwell)
 
+- GPR#965, PR#7426: Fix fatal error during object compilation (also
+  introduces new [Pfield_computed] and [Psetfield_computed] primitives)
+  (Mark Shinwell)
+
 - PR#7346, GPR#966: Fix evaluation order problem whereby expressions could
   be incorrectly re-ordered when compiling with Flambda.  This also fixes one
   example of evaluation order in the native code compiler not matching the

asmcomp/cmmgen.ml

@@ -663,6 +663,9 @@ let float_array_ref dbg arr ofs =
 let addr_array_set arr ofs newval dbg =
   Cop(Cextcall("caml_modify", typ_void, false, None),
       [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+let addr_array_initialize arr ofs newval dbg =
+  Cop(Cextcall("caml_initialize", typ_void, false, None),
+      [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
 let int_array_set arr ofs newval dbg =
   Cop(Cstore (Word_int, Assignment),
     [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
@@ -1583,6 +1586,18 @@ let rec is_unboxed_number ~strict env e =
       join (is_unboxed_number ~strict env e1) e2
   | _ -> No_unboxing
 
+(* Helper for compilation of initialization and assignment operations *)
+
+type assignment_kind = Caml_modify | Caml_initialize | Simple
+
+let assignment_kind ptr init =
+  match init, ptr with
+  | Assignment, Pointer -> Caml_modify
+  | Heap_initialization, Pointer -> Caml_initialize
+  | Assignment, Immediate
+  | Heap_initialization, Immediate
+  | Root_initialization, (Immediate | Pointer) -> Simple
+
 (* Translate an expression *)
 
 let functions = (Queue.create() : ufunction Queue.t)
@@ -2050,21 +2065,21 @@ and transl_prim_1 env p arg dbg =
 and transl_prim_2 env p arg1 arg2 dbg =
   match p with
   (* Heap operations *)
-    Psetfield(n, ptr, init) ->
-      begin match init, ptr with
-      | Assignment, Pointer ->
+  | Pfield_computed ->
+      addr_array_ref (transl env arg1) (transl env arg2) dbg
+  | Psetfield(n, ptr, init) ->
+      begin match assignment_kind ptr init with
+      | Caml_modify ->
         return_unit(Cop(Cextcall("caml_modify", typ_void, false, None),
                         [field_address (transl env arg1) n dbg;
                          transl env arg2],
                         dbg))
-      | Heap_initialization, Pointer ->
+      | Caml_initialize ->
         return_unit(Cop(Cextcall("caml_initialize", typ_void, false, None),
                         [field_address (transl env arg1) n dbg;
                          transl env arg2],
                         dbg))
-      | Assignment, Immediate
-      | Heap_initialization, Immediate
-      | Root_initialization, (Immediate | Pointer) ->
+      | Simple ->
         return_unit(set_field (transl env arg1) n (transl env arg2) init dbg)
       end
   | Psetfloatfield (n, init) ->
@@ -2355,6 +2370,22 @@ and transl_prim_2 env p arg1 arg2 dbg =
 
 and transl_prim_3 env p arg1 arg2 arg3 dbg =
   match p with
+  (* Heap operations *)
+  | Psetfield_computed(ptr, init) ->
+      begin match assignment_kind ptr init with
+      | Caml_modify ->
+        return_unit (
+          addr_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+            dbg)
+      | Caml_initialize ->
+        return_unit (
+          addr_array_initialize (transl env arg1) (transl env arg2)
+            (transl env arg3) dbg)
+      | Simple ->
+        return_unit (
+          int_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+            dbg)
+      end
   (* String operations *)
   | Pbytessetu ->
       return_unit(Cop(Cstore (Byte_unsigned, Assignment),

bytecomp/bytegen.ml

@@ -315,7 +315,9 @@ let comp_primitive p args =
   | Pintcomp cmp -> Kintcomp cmp
   | Pmakeblock(tag, _mut, _) -> Kmakeblock(List.length args, tag)
   | Pfield n -> Kgetfield n
+  | Pfield_computed -> Kgetvectitem
   | Psetfield(n, _ptr, _init) -> Ksetfield n
+  | Psetfield_computed(_ptr, _init) -> Ksetvectitem
   | Pfloatfield n -> Kgetfloatfield n
   | Psetfloatfield (n, _init) -> Ksetfloatfield n
   | Pduprecord _ -> Kccall("caml_obj_dup", 1)

bytecomp/lambda.ml

@@ -61,7 +61,9 @@ type primitive =
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
   | Pfield of int
+  | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
+  | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int

bytecomp/lambda.mli

@@ -66,7 +66,9 @@ type primitive =
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
   | Pfield of int
+  | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
+  | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int

bytecomp/printlambda.ml

@@ -143,6 +143,7 @@ let primitive ppf = function
   | Pmakeblock(tag, Mutable, shape) ->
       fprintf ppf "makemutable %i%a" tag block_shape shape
   | Pfield n -> fprintf ppf "field %i" n
+  | Pfield_computed -> fprintf ppf "field_computed"
   | Psetfield(n, ptr, init) ->
       let instr =
         match ptr with
@@ -156,6 +157,19 @@ let primitive ppf = function
         | Assignment -> ""
       in
       fprintf ppf "setfield_%s%s %i" instr init n
+  | Psetfield_computed (ptr, init) ->
+      let instr =
+        match ptr with
+        | Pointer -> "ptr"
+        | Immediate -> "imm"
+      in
+      let init =
+        match init with
+        | Heap_initialization -> "(heap-init)"
+        | Root_initialization -> "(root-init)"
+        | Assignment -> ""
+      in
+      fprintf ppf "setfield_%s%s_computed" instr init
   | Pfloatfield n -> fprintf ppf "floatfield %i" n
   | Psetfloatfield (n, init) ->
       let init =
@@ -325,7 +339,9 @@ let name_of_primitive = function
   | Psetglobal _ -> "Psetglobal"
   | Pmakeblock _ -> "Pmakeblock"
   | Pfield _ -> "Pfield"
+  | Pfield_computed -> "Pfield_computed"
   | Psetfield _ -> "Psetfield"
+  | Psetfield_computed _ -> "Psetfield_computed"
   | Pfloatfield _ -> "Pfloatfield"
   | Psetfloatfield _ -> "Psetfloatfield"
   | Pduprecord _ -> "Pduprecord"

bytecomp/semantics_of_primitives.ml

@@ -94,6 +94,7 @@ let for_primitive (prim : Lambda.primitive) =
   | Pbigarraydim _ ->
       No_effects, Has_coeffects  (* Some people resize bigarrays in place. *)
   | Pfield _
+  | Pfield_computed
   | Pfloatfield _
   | Pgetglobal _
   | Parrayrefu _
@@ -120,6 +121,7 @@ let for_primitive (prim : Lambda.primitive) =
       (* May trigger a bounds check exception. *)
       Arbitrary_effects, Has_coeffects
   | Psetfield _
+  | Psetfield_computed _
   | Psetfloatfield _
   | Psetglobal _
   | Parraysetu _

bytecomp/translclass.ml

@@ -66,12 +66,8 @@ let transl_meth_list lst =
             (0, List.map (fun lab -> Const_immstring lab) lst))
 
 let set_inst_var obj id expr =
-  let kind =
-    match Typeopt.maybe_pointer expr with
-    | Pointer -> Paddrarray
-    | Immediate -> Pintarray
-  in
-  Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr], Location.none)
+  Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment),
+    [Lvar obj; Lvar id; transl_exp expr], Location.none)
 
 let transl_val tbl create name =
   mkappl (oo_prim (if create then "new_variable" else "get_variable"),
@@ -684,7 +680,7 @@ let transl_class ids cl_id pub_meths cl vflag =
           [lfunction (self :: args)
              (if not (IdentSet.mem env (free_variables body')) then body' else
               Llet(Alias, Pgenval, env,
-                   Lprim(Parrayrefu Paddrarray,
+                   Lprim(Pfield_computed,
                          [Lvar self; Lvar env2],
                          Location.none),
                    body'))]
@@ -695,7 +691,7 @@ let transl_class ids cl_id pub_meths cl vflag =
   let env1 = Ident.create "env" and env1' = Ident.create "env'" in
   let copy_env self =
     if top then lambda_unit else
-    Lifused(env2, Lprim(Parraysetu Paddrarray,
+    Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment),
                         [Lvar self; Lvar env2; Lvar env1'],
                         Location.none))
   and subst_env envs l lam =

bytecomp/translcore.ml

@@ -1008,7 +1008,7 @@ and transl_exp0 e =
              ap_inlined=Default_inline;
              ap_specialised=Default_specialise}
   | Texp_instvar(path_self, path, _) ->
-      Lprim(Parrayrefu Paddrarray,
+      Lprim(Pfield_computed,
             [transl_normal_path path_self; transl_normal_path path], e.exp_loc)
   | Texp_setinstvar(path_self, path, _, expr) ->
       transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr
@@ -1278,12 +1278,8 @@ and transl_let rec_flag pat_expr_list body =
       Lletrec(List.map2 transl_case pat_expr_list idlist, body)
 
 and transl_setinstvar loc self var expr =
-  let prim =
-    match maybe_pointer expr with
-    | Pointer -> Paddrarray
-    | Immediate -> Pintarray
-  in
-  Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr], loc)
+  Lprim(Psetfield_computed (maybe_pointer expr, Assignment),
+    [self; transl_normal_path var; transl_exp expr], loc)
 
 and transl_record loc env fields repres opt_init_expr =
   let size = Array.length fields in

middle_end/inline_and_simplify.ml

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

testsuite/tests/regression/pr7426/Makefile

@@ -0,0 +1,20 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+MAIN_MODULE=pr7426
+
+BASEDIR=../../..
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

testsuite/tests/regression/pr7426/pr7426.ml

@@ -0,0 +1 @@
+class some_class = object val some_val = 0.0 end