Minor fixes for local allocations (#24)

* Comballoc bugfix for local types.

When Comballoc does an actual allocation, the state of the other
allocation must must be preserved, as there are two independent
allocation combining sequences.

* Bugfix for type_function: check return modes of curried lambdas

* Print total local allocations under v=0x400

* Rudimentary GC scanning for local types

Author: stedolan

asmcomp/amd64/emit.mlp

@@ -755,6 +755,9 @@ let emit_instr fallthrough i =
   | Lop(Ibeginregion) ->
       I.mov (domain_field Domainstate.Domain_local_sp) (res i 0)
   | Lop(Iendregion) ->
+      I.mov (arg i 0) r11;
+      I.sub (domain_field Domainstate.Domain_local_sp) r11;
+      I.add r11 (domain_field Domainstate.Domain_local_total);
       I.mov (arg i 0) (domain_field Domainstate.Domain_local_sp)
   | Lop (Iname_for_debugger _) -> ()
   | Lreloadretaddr ->

asmcomp/amd64/proc.ml

@@ -312,6 +312,7 @@ let destroyed_at_oper = function
         -> [| rax |]
   | Iswitch(_, _) -> [| rax; rdx |]
   | Itrywith _ -> [| r11 |]
+  | Iop(Iendregion) -> [| r11 |]
   | _ ->
     if fp then
 (* prevent any use of the frame pointer ! *)

asmcomp/comballoc.ml

@@ -75,8 +75,9 @@ let rec combine i allocstate =
            else instr_cons_debug (Iop(Iintop_imm(Iadd, offset))) i.res
                 i.res i.dbg next
          in
+         let rstate = set_mode mode state (get_mode mode allocstate) in
          (instr_cons_debug (Iop(Ialloc {bytes = totalsz; dbginfo; mode}))
-          i.arg i.res i.dbg next, allocstate)
+          i.arg i.res i.dbg next, rstate)
       end
   | Iop(Icall_ind | Icall_imm _ | Iextcall _ |
         Itailcall_ind | Itailcall_imm _) ->

runtime/caml/domain_state.tbl

@@ -39,6 +39,7 @@ DOMAIN_STATE(struct caml_custom_table*, custom_table)
 DOMAIN_STATE(intnat, local_sp)
 DOMAIN_STATE(struct region_stack*, local_top)
 DOMAIN_STATE(intnat, local_limit)
+DOMAIN_STATE(intnat, local_total)
 
 DOMAIN_STATE(struct mark_stack*, mark_stack)
 /* See major_gc.c */

runtime/memory.c

@@ -691,7 +691,8 @@ CAMLexport void caml_local_region_end(intnat reg)
   Caml_state->local_sp = reg;
 }
 
-#define Local_init_wsz 64
+//#define Local_init_wsz 64
+#define Local_init_wsz (64*1024*1024)
 void caml_local_realloc()
 {
   intnat new_bsize;
@@ -706,6 +707,7 @@ void caml_local_realloc()
   while (Caml_state->local_sp < -new_bsize) new_bsize *= 2;
   stkbase = caml_stat_alloc(new_bsize + sizeof(struct region_stack));
   stk = (struct region_stack*)(stkbase + new_bsize);
+  memset(stkbase, 0x42, new_bsize); /* FIXME debugging only */
   stk->base = stkbase;
   stk->next = Caml_state->local_top;
   Caml_state->local_top = stk;

runtime/roots_nat.c

@@ -330,6 +330,27 @@ void caml_oldify_local_roots (void)
       }
     }
   }
+  /* Local allocations */
+  {
+    header_t* hp = (header_t*)((char*)Caml_state->local_top + Caml_state->local_sp);
+    value start = Val_hp(hp), end = Val_hp((header_t*)Caml_state->local_top);
+    while (hp < (header_t*)Caml_state->local_top) {
+      header_t hd = Hd_hp(hp);
+      CAMLassert(Tag_hd(hd) != Infix_tag);
+      if (Tag_hd(hd) < No_scan_tag) {
+        i = 0;
+        if (Tag_hd(hd) == Closure_tag)
+          i = Start_env_closinfo(Closinfo_val(Val_hp(hp)));
+        for (; i < Wosize_hd(hd); i++) {
+          value* p = Op_hp(hp) + i;
+          if (Is_block(*p) && !(start <= *p && *p < end))
+            Oldify(p);
+        }
+      }
+      hp += Whsize_hd(hd);
+    }
+    CAMLassert(hp == (header_t*)Caml_state->local_top);
+  }
   /* Global C roots */
   caml_scan_global_young_roots(&caml_oldify_one);
   /* Finalised values */
@@ -509,6 +530,27 @@ void caml_do_local_roots_nat(scanning_action f, char * bottom_of_stack,
       }
     }
   }
+  /* Local allocations */
+  {
+    header_t* hp = (header_t*)((char*)Caml_state->local_top + Caml_state->local_sp);
+    value start = Val_hp(hp), end = Val_hp((header_t*)Caml_state->local_top);
+    while (hp < (header_t*)Caml_state->local_top) {
+      header_t hd = Hd_hp(hp);
+      CAMLassert(Tag_hd(hd) != Infix_tag);
+      if (Tag_hd(hd) < No_scan_tag) {
+        i = 0;
+        if (Tag_hd(hd) == Closure_tag)
+          i = Start_env_closinfo(Closinfo_val(Val_hp(hp)));
+        for (; i < Wosize_hd(hd); i++) {
+          value* p = Op_hp(hp) + i;
+          if (Is_block(*p) && !(start <= *p && *p < end))
+            f(*p, p);
+        }
+      }
+      hp += Whsize_hd(hd);
+    }
+    CAMLassert(hp == (header_t*)Caml_state->local_top);
+  }
 }
 
 uintnat (*caml_stack_usage_hook)(void) = NULL;

runtime/sys.c

@@ -150,6 +150,8 @@ CAMLprim value caml_sys_exit(value retcode_v)
     caml_gc_message(0x400,
                     "forced_major_collections: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
                     forcmajcoll);
+    caml_gc_message(0x400, "local_words: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
+                    Wsize_bsize(Caml_state->local_total));
   }
 
 #ifndef NATIVE_CODE

typing/typecore.ml

@@ -3814,11 +3814,15 @@ and type_function ?in_function loc attrs env mode ty_expected_explained l caseli
                                           ty_fun,
                                           explanation)))
   in
-  if not curry then
-    begin match Types.Alloc_mode.submode ret_mode Alloc_heap with
+  if curry then begin
+    match Types.Alloc_mode.submode mode ret_mode with
     | Ok () -> ()
     | Error _ -> raise (Error(loc, env, Local_return_value_escapes))
-    end;
+  end else begin
+    match Types.Alloc_mode.submode ret_mode Alloc_heap with
+    | Ok () -> ()
+    | Error _ -> raise (Error(loc, env, Local_return_value_escapes))
+  end;
   let ty_arg =
     if is_optional l then
       let tv = newvar() in