Alter array patch after feedback from jdimino

asmcomp/cmmgen.ml

@@ -1502,8 +1502,13 @@ let rec transl env e =
           make_alloc tag (List.map (transl env) args)
       | (Pccall prim, args) ->
           transl_ccall env prim args dbg
-      | (Pduparray (Pfloatarray as kind, _),
-            [Uprim (Pmakearray (Pfloatarray, _), args, _dbg)]) ->
+      | (Pduparray (kind, _), [Uprim (Pmakearray (kind', _), args, _dbg)]) ->
+          (* We arrive here in two cases:
+             1. When using Closure, all the time.
+             2. When using Flambda, if a float array longer than
+             [Translcore.use_dup_for_constant_arrays_bigger_than] turns out
+             to be non-constant. *)
+          assert (kind = kind');
           transl_make_array env kind args
       | (Pduparray _, [arg]) ->
           let prim_obj_dup =

bytecomp/bytegen.ml

@@ -646,13 +646,16 @@ let rec comp_expr env exp sz cont =
                  (Kmakeblock(List.length args, 0) ::
                   Kccall("caml_make_array", 1) :: cont)
       end
+  | Lprim (Pduparray (kind, mutability), [Lprim (Pmakearray (kind', _), args)]) ->
+      assert (kind = kind');
+      comp_expr env (Lprim (Pmakearray (kind, mutability), args)) sz cont
   | Lprim (Pduparray _, [arg]) ->
-    let prim_obj_dup =
-      Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
-    in
-    comp_expr env (Lprim (Pccall prim_obj_dup, [arg])) sz cont
+      let prim_obj_dup =
+        Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
+      in
+      comp_expr env (Lprim (Pccall prim_obj_dup, [arg])) sz cont
   | Lprim (Pduparray _, _) ->
-    Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg"
+      Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg"
 (* Integer first for enabling futher optimization (cf. emitcode.ml)  *)
   | Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) ->
       let p = Pintcomp (commute_comparison c)

bytecomp/translcore.ml

@@ -858,24 +858,32 @@ and transl_exp0 e =
         then begin
           raise Not_constant
         end;
-        (* We cannot currently lift [Pintarray] arrays safely in Flambda
-           because [caml_modify] might be called upon them (e.g. from
-           code operating on polymorphic arrays, or functions such as
-           [caml_array_blit]. *)
-        if !Clflags.native_code && kind = Pfloatarray then
-          let imm_array = Lprim (Pmakearray (kind, Immutable), ll) in
-          Lprim (Pduparray (kind, Mutable), [imm_array])
-        else begin
-          let cl = List.map extract_constant ll in
-          let master =
-            match kind with
-            | Paddrarray | Pintarray ->
-                Lconst(Const_block(0, cl))
-            | Pfloatarray ->
-                Lconst(Const_float_array(List.map extract_float cl))
-            | Pgenarray ->
-                raise Not_constant in             (* can this really happen? *)
-          Lprim(Pccall prim_obj_dup, [master])
+        begin match List.map extract_constant ll with
+        | exception Not_constant when kind = Pfloatarray ->
+            (* We cannot currently lift [Pintarray] arrays safely in Flambda
+               because [caml_modify] might be called upon them (e.g. from
+               code operating on polymorphic arrays, or functions such as
+               [caml_array_blit].
+               To avoid having different Lambda code for bytecode/Closure vs.
+               flambda, we always generate [Pduparray] here, and deal with it in
+               [Bytegen] (or in the case of Closure, in [Cmmgen], which already
+               has to handle [Pduparray Pmakearray Pfloatarray] in the case where
+               the array turned out to be inconstant.
+               When not [Pfloatarray], the exception propagates to the handler
+               below. *)
+            let imm_array = Lprim (Pmakearray (kind, Immutable), ll) in
+            Lprim (Pduparray (kind, Mutable), [imm_array])
+        | cl ->
+            let imm_array =
+              match kind with
+              | Paddrarray | Pintarray ->
+                  Lconst(Const_block(0, cl))
+              | Pfloatarray ->
+                  Lconst(Const_float_array(List.map extract_float cl))
+              | Pgenarray ->
+                  raise Not_constant                (* can this really happen? *)
+            in
+            Lprim (Pduparray (kind, Mutable), [imm_array])
         end
       with Not_constant ->
         Lprim(Pmakearray (kind, Mutable), ll)

middle_end/closure_conversion.ml

@@ -149,7 +149,8 @@ let rec close_const t env (const : Lambda.structured_constant)
   | Const_pointer c -> Const (Const_pointer c), "pointer"
   | Const_immstring c -> Allocated_const (Immutable_string c), "immstring"
   | Const_float_array c ->
-    Allocated_const (Float_array (List.map float_of_string c)), "float_array"
+    Allocated_const (Immutable_float_array (List.map float_of_string c)),
+      "float_array"
   | Const_block _ ->
     Expr (close t env (eliminate_const_block const)), "const_block"