Code generation and runtime fix for ocaml#8699, ocaml#8681

stedolan · Jun 4, 2019 · d946686 · d946686
1 parent 495434a
commit d946686
Show file tree

Hide file tree

Showing 4 changed files with 73 additions and 14 deletions.
diff --git a/Changes b/Changes
@@ -64,6 +64,9 @@ Working version
 - #8622: Don't generate #! headers over 127 characters.
   (David Allsopp, review by Xavier Leroy and Stephen Dolan)
 
+- #8712: Fix code generation with nested let rec of functions.
+  (Stephen Dolan, Leo White, Gabriel Scherer and Pierre Chambart)
+
 OCaml 4.09.0
 ------------
 

diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
@@ -899,6 +899,7 @@ let fundecls_size fundecls =
 
 type rhs_kind =
   | RHS_block of int
+  | RHS_blockoffset of int * int
   | RHS_floatblock of int
   | RHS_nonrec
 ;;
@@ -940,6 +941,10 @@ let rec expr_size env = function
       expr_size env closure
   | Usequence(_exp, exp') ->
       expr_size env exp'
+  | Uoffset (exp, ofs) ->
+      (match expr_size env exp with
+      | RHS_block sz -> RHS_blockoffset (sz, ofs)
+      | _ -> assert false)
   | _ -> RHS_nonrec
 
 (* Record application and currying functions *)
@@ -3194,27 +3199,32 @@ and transl_letrec env bindings cont =
     List.map (fun (id, exp) -> (id, exp, expr_size V.empty exp))
       bindings
   in
-  let op_alloc prim sz =
-    Cop(Cextcall(prim, typ_val, true, None), [int_const dbg sz], dbg) in
+  let op_alloc prim args =
+    Cop(Cextcall(prim, typ_val, true, None), args, dbg) in
   let rec init_blocks = function
     | [] -> fill_nonrec bsz
     | (id, _exp, RHS_block sz) :: rem ->
-        Clet(id, op_alloc "caml_alloc_dummy" sz,
+        Clet(id, op_alloc "caml_alloc_dummy" [int_const dbg sz],
           init_blocks rem)
+    | (id, _exp, RHS_blockoffset(sz, ofs)) :: rem ->
+        Clet(id, op_alloc "caml_alloc_dummy_infix"
+             [int_const dbg sz; int_const dbg ofs],
+             init_blocks rem)
     | (id, _exp, RHS_floatblock sz) :: rem ->
-        Clet(id, op_alloc "caml_alloc_dummy_float" sz,
+        Clet(id, op_alloc "caml_alloc_dummy_float" [int_const dbg sz],
           init_blocks rem)
     | (id, _exp, RHS_nonrec) :: rem ->
         Clet (id, Cconst_int (0, dbg), init_blocks rem)
   and fill_nonrec = function
     | [] -> fill_blocks bsz
-    | (_id, _exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
+    | (_id, _exp,
+       (RHS_block _ | RHS_blockoffset _ | RHS_floatblock _)) :: rem ->
         fill_nonrec rem
     | (id, exp, RHS_nonrec) :: rem ->
         Clet(id, transl env exp, fill_nonrec rem)
   and fill_blocks = function
     | [] -> cont
-    | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
+    | (id, exp, (RHS_block _ | RHS_blockoffset _ | RHS_floatblock _)) :: rem ->
         let op =
           Cop(Cextcall("caml_update_dummy", typ_void, false, None),
               [Cvar (VP.var id); transl env exp], dbg) in

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
@@ -129,6 +129,7 @@ let rec push_dummies n k = match n with
 
 type rhs_kind =
   | RHS_block of int
+  | RHS_blockoffset of int * int
   | RHS_floatblock of int
   | RHS_nonrec
   | RHS_function of int * int
@@ -158,6 +159,18 @@ let rec size_of_lambda env = function
       end
   | Llet(_str, _k, id, arg, body) ->
       size_of_lambda (Ident.add id (size_of_lambda env arg) env) body
+  (* See the Lletrec case of comp_expr *)
+  | Lletrec(bindings, body) when
+      List.for_all (function (_, Lfunction _) -> true | _ -> false) bindings ->
+      (* let rec of functions *)
+      let fv =
+        Ident.Set.elements (free_variables (Lletrec(bindings, lambda_unit))) in
+      (* See Instruct(CLOSUREREC) in interp.c *)
+      let sz = List.length bindings * 2 - 1 + List.length fv in
+      let offsets = List.mapi (fun i (id, _e) -> (id, i * 2)) bindings in
+      let env = List.fold_right (fun (id, ofs) env ->
+        Ident.add id (RHS_blockoffset (sz, ofs)) env) offsets env in
+      size_of_lambda env body
   | Lletrec(bindings, body) ->
       let env = List.fold_right
         (fun (id, e) env -> Ident.add id (size_of_lambda env e) env)
@@ -567,6 +580,12 @@ let rec comp_expr env exp sz cont =
               Kconst(Const_base(Const_int blocksize)) ::
               Kccall("caml_alloc_dummy", 1) :: Kpush ::
               comp_init (add_var id (sz+1) new_env) (sz+1) rem
+          | (id, _exp, RHS_blockoffset (blocksize, ofs)) :: rem ->
+              Kconst(Const_base(Const_int ofs)) ::
+              Kpush ::
+              Kconst(Const_base(Const_int blocksize)) ::
+              Kccall("caml_alloc_dummy_infix", 2) :: Kpush ::
+              comp_init (add_var id (sz+1) new_env) (sz+1) rem
           | (id, _exp, RHS_function (blocksize,arity)) :: rem ->
               Kconst(Const_base(Const_int arity)) ::
               Kpush ::
@@ -578,15 +597,17 @@ let rec comp_expr env exp sz cont =
               comp_init (add_var id (sz+1) new_env) (sz+1) rem
         and comp_nonrec new_env sz i = function
           | [] -> comp_rec new_env sz ndecl decl_size
-          | (_id, _exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
+          | (_id, _exp, (RHS_block _ | RHS_blockoffset _ |
+                         RHS_floatblock _ | RHS_function _))
             :: rem ->
               comp_nonrec new_env sz (i-1) rem
           | (_id, exp, RHS_nonrec) :: rem ->
               comp_expr new_env exp sz
                 (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem)
         and comp_rec new_env sz i = function
           | [] -> comp_expr new_env body sz (add_pop ndecl cont)
-          | (_id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
+          | (_id, exp, (RHS_block _ | RHS_blockoffset _ |
+                        RHS_floatblock _ | RHS_function _))
             :: rem ->
               comp_expr new_env exp sz
                 (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) ::

diff --git a/runtime/alloc.c b/runtime/alloc.c
@@ -222,23 +222,48 @@ CAMLprim value caml_alloc_dummy_float (value size)
   return caml_alloc (wosize, 0);
 }
 
+CAMLprim value caml_alloc_dummy_infix(value vsize, value voffset)
+{
+  mlsize_t wosize = Long_val(vsize), offset = Long_val(voffset);
+  value v = caml_alloc(wosize, Closure_tag);
+  if (offset > 0) {
+    v += Bsize_wsize(offset);
+    Hd_val(v) = Make_header(offset, Infix_tag, Caml_white);
+  }
+  return v;
+}
+
 CAMLprim value caml_update_dummy(value dummy, value newval)
 {
   mlsize_t size, i;
   tag_t tag;
 
-  size = Wosize_val(newval);
   tag = Tag_val (newval);
-  CAMLassert (size == Wosize_val(dummy));
-  CAMLassert (tag < No_scan_tag || tag == Double_array_tag);
 
-  Tag_val(dummy) = tag;
   if (tag == Double_array_tag){
+    CAMLassert (Wosize_val(newval) == Wosize_val(dummy));
+    CAMLassert (tag < No_scan_tag || tag == Double_array_tag);
+    Tag_val(dummy) = tag;
     size = Wosize_val (newval) / Double_wosize;
-    for (i = 0; i < size; i++){
+    for (i = 0; i < size; i++) {
       Store_double_flat_field (dummy, i, Double_flat_field (newval, i));
     }
-  }else{
+  } else if (tag == Infix_tag) {
+    value clos = newval - Infix_offset_hd(Hd_val(newval));
+    CAMLassert (Tag_val(clos) == Closure_tag);
+    CAMLassert (Tag_val(dummy) == Infix_tag);
+    CAMLassert (Infix_offset_val(dummy) == Infix_offset_val(newval));
+    dummy = dummy - Infix_offset_val(dummy);
+    size = Wosize_val(clos);
+    CAMLassert (size == Wosize_val(dummy));
+    for (i = 0; i < size; i++) {
+      caml_modify (&Field(dummy, i), Field(clos, i));
+    }
+  } else {
+    CAMLassert (tag < No_scan_tag || tag == Double_array_tag);
+    Tag_val(dummy) = tag;
+    size = Wosize_val(newval);
+    CAMLassert (size == Wosize_val(dummy));
     for (i = 0; i < size; i++){
       caml_modify (&Field(dummy, i), Field(newval, i));
     }