diff -C 2 -b -w -r ocaml-3.12.1-orig/asmcomp/cmmgen.ml ../ocaml-3.12.1/asmcomp/cmmgen.ml
*** ocaml-3.12.1-orig/asmcomp/cmmgen.ml	2010-11-11 18:08:07.000000000 +0100
--- ../ocaml-3.12.1/asmcomp/cmmgen.ml	2011-10-25 14:12:24.670561997 +0200
***************
*** 1501,1505 ****
--- 1501,1657 ----
            (Array.of_list !inters) actions)

+ (*
+    better_transl_letrec: we are going to combine all allocations
+    requiring a recursive binding in one big allocation, hoping that
+    all initializations are either recursive allocations (in which case
+    they are combined), or not recursive (in which case they can be
+    allocated before). If the strategy is not successful, just fallback
+    to the former let-rec compilation algorithm.
+ *)
+
+ and better_transl_letrec bindings cont =
+   let block_id = Ident.create "letrec_block" in
+
+   let set = ref IdentSet.empty in
+   List.iter (fun (id, exp) -> set := IdentSet.add id !set) bindings;
+
+   let cont = ref cont in
+
+   (* [combine_allocs]: combine all allocations in one, and binds the
+     identifiers to offsets in the allocated block. *)
+   let combine_allocs allocs =
+
+     let rec combine current_size args lets allocs =
+       match allocs with
+           [] -> (current_size, args, lets)
+         | (id, tag, fields) :: allocs ->
+           let lets =
+             (id, field_address (Cvar block_id) current_size) :: lets
+           in
+           let wordsize = List.length fields in
+           let fields = Cconst_natint(block_header tag wordsize) :: fields in
+           let current_size = current_size + 1 + wordsize in
+           let args = args @ fields in
+           combine current_size args lets allocs
+     in
+     let (wordsize, args, lets) = combine 0 [] [] allocs in
+     (* This optimization is only worth if the block is
+        allocated in the minor heap: *)
+     if wordsize > Config.max_young_wosize then raise Exit;
+     Clet( block_id, Cop( Calloc, args ),
+           let rec add_lets lets cont =
+             match lets with
+                 [] -> cont
+               | (id, v) :: lets ->
+                 add_lets lets (Clet( id, v, cont))
+           in
+           add_lets lets !cont
+     )
+   in
+   let rec for_bindings bindings allocs =
+     match bindings with
+         [] -> combine_allocs allocs
+       | (id, exp) :: bindings ->
+         for_binding id exp bindings allocs
+
+   and for_binding id exp bindings allocs =
+     match exp with
+ (*
+   | Uclosure(fundecls, clos_vars) ->
+       RHS_block (fundecls_size fundecls + List.length clos_vars)
+   | Uletrec(bindings, body) ->
+       expr_size body
+ *)
+       | Usequence(exp, exp') ->
+         if non_rec_exp exp then
+           Csequence ( transl exp, for_binding id exp' bindings allocs)
+         else raise Exit
+       | Ulet(id2, exp2, body) ->
+         if non_rec_exp exp2 then
+           Clet (id2, transl exp2,
+                 for_binding id body bindings allocs)
+         else raise Exit
+       | Uprim( Pmakearray(Paddrarray | Pintarray), args, _) ->
+         for_fields bindings id 0 (List.rev args) [] allocs
+       | Uprim(Pmakeblock(tag, mut), args, _) ->
+         for_fields bindings id tag (List.rev args) [] allocs
+       | _ ->
+         if non_rec_exp exp then
+           Clet (id, transl exp, for_bindings bindings allocs)
+         else raise Exit
+
+   (* For each field of a recursive block, either the field value is not
+      recursive, in which case it can be computed before, or it is
+      recursive, in which case it is first initialized with 1, and we
+      modify the continuation to set the field with the correct value after
+      the allocation. We could probably handle more cases for the value in
+      the field, but it is not clear that is is worth it.
+   *)
+
+   and for_fields bindings id tag r_args fields allocs =
+     match r_args with
+         [] -> for_bindings bindings ( (id, tag, fields) :: allocs )
+       | arg :: r_args ->
+         if non_rec_exp arg then
+           for_fields bindings id tag r_args (transl arg :: fields) allocs
+         else
+           let n = List.length r_args in
+           match arg with
+               Uvar field_id when IdentSet.mem field_id !set ->
+                 cont := Csequence ( set_field (Cvar id) n (Cvar field_id) , !cont );
+                 for_fields bindings id tag r_args ( Cconst_int 1 :: fields) allocs
+             | _ ->
+               let field_id_name = Printf.sprintf "%s_rec_%d" (Ident.name id) n in
+               let field_id = Ident.create field_id_name in
+               cont := Csequence( set_field (Cvar id) n (Cvar field_id) , !cont);
+               set := IdentSet.add field_id !set;
+               for_fields ( (field_id, arg) :: bindings ) id tag r_args
+                 ( Cconst_int 1 :: fields) allocs
+
+   (* [non_rec_exp exp] returns [true] if the current expression does
+      not use the recursively defined identifiers, in which case it can
+      be executed before allocating the recursive block.  *)
+   and non_rec_exp exp =
+     let rec non_rec_exp exp =
+       match exp with
+           Uvar id -> if IdentSet.mem id !set then raise Exit
+         | Uconst _ -> ()
+         | Udirect_apply (_, ulist, _) -> List.iter non_rec_exp ulist
+         | Ugeneric_apply (u, ulist, _) -> non_rec_exp u; List.iter non_rec_exp ulist
+         | Uclosure (flist, ulist) ->
+           List.iter (fun (_, _, _, u) -> non_rec_exp u) flist;
+           List.iter non_rec_exp ulist
+         | Uoffset (u, _) -> non_rec_exp u
+         | Ulet (_, u1, u2) -> non_rec_exp u1; non_rec_exp u2
+         | Uletrec (bindings, u) ->
+           List.iter (fun (_, u) -> non_rec_exp u) bindings; non_rec_exp u
+         | Uprim (_, ulist, _) -> List.iter non_rec_exp ulist
+         | Uswitch (u, us) ->
+           non_rec_exp u;
+           Array.iter non_rec_exp us.us_actions_consts;
+           Array.iter non_rec_exp us.us_actions_blocks;
+         | Ustaticfail (_, ulist) -> List.iter non_rec_exp ulist
+         | Ucatch (_, _, u1, u2) -> non_rec_exp u1; non_rec_exp u2
+         | Utrywith (u1, _, u2) -> non_rec_exp u2; non_rec_exp u2
+         | Uifthenelse (u1, u2, u3) -> non_rec_exp u1; non_rec_exp u2; non_rec_exp u3
+         | Usequence (u1, u2) -> non_rec_exp u1; non_rec_exp u2
+         | Uwhile (u1, u2) -> non_rec_exp u1; non_rec_exp u2
+         | Ufor (_, u1, u2, _, u3) -> non_rec_exp u1; non_rec_exp u2; non_rec_exp u3
+         | Uassign (_, u1) -> non_rec_exp u1
+         | Usend (_, u1, u2, ulist, _) ->
+           non_rec_exp u1; non_rec_exp u2;
+           List.iter non_rec_exp ulist
+     in
+     try non_rec_exp exp; true with Exit -> false
+
+   in
+   for_bindings bindings []
+
+ (* try to call [better_transl_letrec], and if an Exit exception is
+    raised, fallback to default strategy. *)
  and transl_letrec bindings cont =
+   try
+     better_transl_letrec bindings cont
+   with Exit ->
      let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in
      let rec init_blocks = function