Fix code generation with nested let rec of functions

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
 ------------
 

asmcomp/cmmgen.ml

@@ -899,6 +899,7 @@ let fundecls_size fundecls =
 
 type rhs_kind =
   | RHS_block of int
+  | RHS_infix of { blocksize : int; offset : int }
   | RHS_floatblock of int
   | RHS_nonrec
 ;;
@@ -940,6 +941,11 @@ let rec expr_size env = function
       expr_size env closure
   | Usequence(_exp, exp') ->
       expr_size env exp'
+  | Uoffset (exp, offset) ->
+      (match expr_size env exp with
+      | RHS_block blocksize -> RHS_infix { blocksize; offset }
+      | RHS_nonrec -> RHS_nonrec
+      | _ -> assert false)
   | _ -> RHS_nonrec
 
 (* Record application and currying functions *)
@@ -3194,27 +3200,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_infix { blocksize; offset}) :: rem ->
+        Clet(id, op_alloc "caml_alloc_dummy_infix"
+             [int_const dbg blocksize; int_const dbg offset],
+             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_infix _ | 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_infix _ | RHS_floatblock _)) :: rem ->
         let op =
           Cop(Cextcall("caml_update_dummy", typ_void, false, None),
               [Cvar (VP.var id); transl env exp], dbg) in

bytecomp/bytegen.ml

@@ -129,6 +129,7 @@ let rec push_dummies n k = match n with
 
 type rhs_kind =
   | RHS_block of int
+  | RHS_infix of { blocksize : int; offset : 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 blocksize = 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, offset) env ->
+        Ident.add id (RHS_infix { blocksize; offset }) 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_infix { blocksize; offset }) :: rem ->
+              Kconst(Const_base(Const_int offset)) ::
+              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_infix _ |
+                         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_infix _ |
+                        RHS_floatblock _ | RHS_function _))
             :: rem ->
               comp_expr new_env exp sz
                 (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) ::

runtime/alloc.c

@@ -222,23 +222,49 @@ 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_val(dummy) != Infix_tag);
+    Tag_val(dummy) = Double_array_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);
+    CAMLassert (Tag_val(dummy) != Infix_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));
     }

testsuite/tests/letrec-compilation/ocamltests

@@ -14,5 +14,6 @@ mixing_value_closures_2.ml
 mutual_functions.ml
 nested.ml
 pr4989.ml
+pr8681.ml
 record_with.ml
 ref.ml

testsuite/tests/letrec-compilation/pr8681.ml

@@ -0,0 +1,63 @@
+(* TEST *)
+let rec h =
+  let rec f n = if n >= 0 then g (n - 1)
+  and g n = h n; f n in
+  f
+
+let () = Gc.minor ()
+let () = ignore (h 10)
+
+let mooo x =
+  let rec h =
+    ignore (Sys.opaque_identity x);
+    let rec g n = h n; f n
+    and f n = if n >= 0 then g (n - 1) in
+    f
+  in
+  h
+
+let h = mooo 3
+let () = Gc.minor ()
+let () = ignore (h 10)
+
+
+let rec foo =
+  let rec f = function
+    | 0 -> 100
+    | n -> foo (n-1)
+  and g = function
+    | 0 -> 200
+    | n -> f (n-1) in
+  g
+
+let () = print_int (foo 2); print_newline ()
+let () = print_int (foo 7); print_newline ()
+
+
+let with_free_vars a b c =
+  let rec foo =
+    let rec f = function
+      | 0 -> 100 + a + b + c
+      | n -> foo (n-1)
+    and g = function
+      | 0 -> 200 + a + b + c
+      | n -> f (n-1) in
+    g in
+  foo
+
+let () = print_int (with_free_vars 1 2 3 2); print_newline ()
+let () = print_int (with_free_vars 1 2 3 7); print_newline ()
+
+let bar =
+  let rec f = function
+    | 0 -> 3
+    | n -> g (n - 1)
+  and g = function
+    | 0 -> 10 + f 10
+    | n -> f (n - 1)
+  in
+  let rec foof = f
+  and goof = g
+  in (foof, goof)
+
+let () = print_int (snd bar 42); print_newline ()

testsuite/tests/letrec-compilation/pr8681.reference

@@ -0,0 +1,5 @@
+200
+100
+206
+106
+13