From 8531422de9fd86dbe5c12db569d98cc96af801bb Mon Sep 17 00:00:00 2001
From: Gabriel Scherer <gabriel.scherer@inria.fr>
Date: Mon, 19 Dec 2011 16:25:02 +0100
Subject: [PATCH 2/4] cmmgen: fix letrec-bindings float array segfault

By copying the RHS_floatblock logic from bytegen.ml, we fix
a cmmgen.ml bug causing evaluation order changes or segfaults (see
'letrec' testsuite).
---
 asmcomp/cmmgen.ml |   23 +++++++++++++++--------
 1 files changed, 15 insertions(+), 8 deletions(-)

diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 61fef31..46b002f 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -381,6 +381,7 @@ let fundecls_size fundecls =
 
 type rhs_kind =
   | RHS_block of int
+  | RHS_floatblock of int
   | RHS_nonrec
 ;;
 let rec expr_size = function
@@ -394,6 +395,8 @@ let rec expr_size = function
       RHS_block (List.length args)
   | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) ->
       RHS_block (List.length args)
+  | Uprim(Pmakearray(Pfloatarray), args, _) ->
+      RHS_floatblock (List.length args)
   | Usequence(exp, exp') ->
       expr_size exp'
   | _ -> RHS_nonrec
@@ -1504,25 +1507,29 @@ and transl_switch arg index cases = match Array.length cases with
 
 and transl_letrec bindings cont =
   let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in
+  let op_alloc prim sz =
+    Cop(Cextcall(prim, typ_addr, true, Debuginfo.none), [int_const sz]) in
   let rec init_blocks = function
     | [] -> fill_nonrec bsz
     | (id, exp, RHS_block sz) :: rem ->
-        Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true, Debuginfo.none),
-                     [int_const sz]),
-             init_blocks rem)
+        Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem)
+    | (id, exp, RHS_floatblock sz) :: rem ->
+        Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem)
     | (id, exp, RHS_nonrec) :: rem ->
         Clet (id, Cconst_int 0, init_blocks rem)
   and fill_nonrec = function
     | [] -> fill_blocks bsz
-    | (id, exp, RHS_block sz) :: rem -> fill_nonrec rem
+    | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
+        fill_nonrec rem
     | (id, exp, RHS_nonrec) :: rem ->
         Clet (id, transl exp, fill_nonrec rem)
   and fill_blocks = function
     | [] -> cont
-    | (id, exp, RHS_block _) :: rem ->
-        Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none),
-                      [Cvar id; transl exp]),
-                  fill_blocks rem)
+    | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
+        let op =
+          Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none),
+              [Cvar id; transl exp]) in
+        Csequence(op, fill_blocks rem)
     | (id, exp, RHS_nonrec) :: rem ->
         fill_blocks rem
   in init_blocks bsz
-- 
1.7.7.3