File ocaml-Fixes-for-out-of-range-Ialloc.patch of Package ocaml

From 664f0763d37f85e2ec53d6394251b5948dcfa727 Mon Sep 17 00:00:00 2001
From: Mark Shinwell <mshinwell@janestreet.com>
Date: Mon, 31 Jul 2017 14:37:47 +0100
Subject: Fixes for out-of-range Ialloc

Cherry-pick of GPR#1271 which was merged on trunk.

Fixes for Ialloc instructions allocating more than Max_young_wosize words in the minor heap

Out-of-range Ialloc instructions cause various problems, see in particular GPR #1250.
---
 Changes                                     |   5 +
 asmcomp/cmmgen.ml                           |  38 ++--
 asmcomp/selectgen.ml                        |   3 +-
 testsuite/tests/basic-more/pr1271.ml        | 288 ++++++++++++++++++++++++++++
 testsuite/tests/basic-more/pr1271.reference |   2 +
 5 files changed, 317 insertions(+), 19 deletions(-)
 create mode 100644 testsuite/tests/basic-more/pr1271.ml
 create mode 100644 testsuite/tests/basic-more/pr1271.reference

diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 4ac4b40c6..2120d3985 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -1641,29 +1641,31 @@ let rec transl env e =
       List.iter (fun f -> Queue.add f functions) fundecls;
       Cconst_symbol lbl
   | Uclosure(fundecls, clos_vars) ->
-      let block_size =
-        fundecls_size fundecls + List.length clos_vars in
       let rec transl_fundecls pos = function
           [] ->
             List.map (transl env) clos_vars
         | f :: rem ->
             Queue.add f functions;
-            let header =
-              if pos = 0
-              then alloc_closure_header block_size f.dbg
-              else alloc_infix_header pos f.dbg in
-            if f.arity = 1 || f.arity = 0 then
-              header ::
-              Cconst_symbol f.label ::
-              int_const f.arity ::
-              transl_fundecls (pos + 3) rem
-            else
-              header ::
-              Cconst_symbol(curry_function f.arity) ::
-              int_const f.arity ::
-              Cconst_symbol f.label ::
-              transl_fundecls (pos + 4) rem in
-      Cop(Calloc, transl_fundecls 0 fundecls, Debuginfo.none)
+            let without_header =
+              if f.arity = 1 || f.arity = 0 then
+                Cconst_symbol f.label ::
+                int_const f.arity ::
+                transl_fundecls (pos + 3) rem
+              else
+                Cconst_symbol(curry_function f.arity) ::
+                int_const f.arity ::
+                Cconst_symbol f.label ::
+                transl_fundecls (pos + 4) rem
+            in
+            if pos = 0 then without_header
+            else (alloc_infix_header pos f.dbg) :: without_header
+      in
+      let dbg =
+        match fundecls with
+        | [] -> Debuginfo.none
+        | fundecl::_ -> fundecl.dbg
+      in
+      make_alloc dbg Obj.closure_tag (transl_fundecls 0 fundecls)
   | Uoffset(arg, offset) ->
       (* produces a valid Caml value, pointing just after an infix header *)
       let ptr = transl env arg in
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 7cd8cd5c3..1158fc0d0 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -738,7 +738,8 @@ method emit_expr (env:environment) exp =
                   loc_arg (Proc.loc_external_results rd) in
               self#insert_move_results loc_res rd stack_ofs;
               Some rd
-          | Ialloc { words = _; spacetime_index; label_after_call_gc; } ->
+          | Ialloc { words; spacetime_index; label_after_call_gc; } ->
+              assert (words <= Config.max_young_wosize);
               let rd = self#regs_for typ_val in
               let size = size_expr env (Ctuple new_args) in
               let op =