Support local allocations in i386 and fix amd64 bug (#31)

* i386 local allocation support

* Bugfix for local alloc counting logic on amd64

Author: stedolan

asmcomp/amd64/emit.mlp

@@ -758,7 +758,8 @@ let emit_instr fallthrough i =
       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)
+      I.add (domain_field Domainstate.Domain_local_sp) r11;
+      I.mov r11 (domain_field Domainstate.Domain_local_sp)
   | Lop (Iname_for_debugger _) -> ()
   | Lreloadretaddr ->
       ()

asmcomp/i386/emit.mlp

@@ -236,6 +236,19 @@ let emit_call_gc gc =
   def_label gc.gc_frame;
   I.jmp (label gc.gc_return_lbl)
 
+(* Record calls to local stack reallocation *)
+
+type local_realloc_call =
+  { lr_lbl: label;
+    lr_return_lbl: label; }
+
+let local_realloc_sites = ref ([] : local_realloc_call list)
+
+let emit_local_realloc lr =
+  def_label lr.lr_lbl;
+  emit_call "caml_call_local_realloc";
+  I.jmp (label lr.lr_return_lbl)
+
 (* Record calls to caml_ml_array_bound_error.
    In -g mode, we maintain one call to caml_ml_array_bound_error
    per bound check site.  Without -g, we can share a single call. *)
@@ -608,7 +621,7 @@ let emit_instr fallthrough i =
             I.fstp (addressing addr REAL8 i 1)
           end
       end
-  | Lop(Ialloc { bytes = n; dbginfo }) ->
+  | Lop(Ialloc { bytes = n; dbginfo; mode = Alloc_heap }) ->
       if !fastcode_flag then begin
         load_domain_state ebx;
         I.mov (domain_field Domain_young_ptr RBX) eax;
@@ -643,6 +656,21 @@ let emit_instr fallthrough i =
         def_label label;
         I.lea (mem32 NONE 4 RAX) (reg i.res.(0))
       end
+  | Lop(Ialloc {bytes = n; dbginfo=_; mode = Alloc_local }) ->
+      load_domain_state ebx;
+      I.mov (domain_field Domainstate.Domain_local_sp RBX) eax;
+      I.sub (int n) eax;
+      I.mov eax (domain_field Domainstate.Domain_local_sp RBX);
+      I.cmp (domain_field Domainstate.Domain_local_limit RBX) eax;
+      let lbl_call = new_label () in
+      I.j L (label lbl_call);
+      let lbl_after_alloc = new_label () in
+      def_label lbl_after_alloc;
+      I.add (domain_field Domainstate.Domain_local_top RBX) eax;
+      I.lea (mem32 NONE 4 RAX) (reg i.res.(0));
+      local_realloc_sites :=
+        { lr_lbl = lbl_call;
+          lr_return_lbl = lbl_after_alloc } :: !local_realloc_sites
   | Lop(Iintop(Icomp cmp)) ->
       I.cmp (reg i.arg.(1)) (reg i.arg.(0));
       I.set (cond cmp) al;
@@ -799,6 +827,16 @@ let emit_instr fallthrough i =
       if Array.length i.arg = 2 && is_tos i.arg.(1) then
         I.fxch st1;
       emit_floatspecial s
+  | Lop (Ibeginregion) ->
+     load_domain_state ebx;
+     I.mov (domain_field Domainstate.Domain_local_sp RBX) (reg i.res.(0))
+  | Lop (Iendregion) ->
+     I.mov (reg i.arg.(0)) eax;
+     load_domain_state ebx;
+     I.sub (domain_field Domainstate.Domain_local_sp RBX) eax;
+     I.add eax (domain_field Domainstate.Domain_local_total RBX);
+     I.add (domain_field Domainstate.Domain_local_sp RBX) eax;
+     I.mov eax (domain_field Domainstate.Domain_local_sp RBX)
   | Lop (Iname_for_debugger _) -> ()
   | Lreloadretaddr ->
       ()
@@ -922,6 +960,7 @@ let fundecl fundecl =
   tailrec_entry_point := fundecl.fun_tailrec_entry_point_label;
   stack_offset := 0;
   call_gc_sites := [];
+  local_realloc_sites := [];
   bound_error_sites := [];
   bound_error_call := 0;
   for i = 0 to Proc.num_register_classes - 1 do
@@ -937,6 +976,7 @@ let fundecl fundecl =
   cfi_startproc ();
   emit_all true fundecl.fun_body;
   List.iter emit_call_gc !call_gc_sites;
+  List.iter emit_local_realloc !local_realloc_sites;
   emit_call_bound_errors ();
   cfi_endproc ();
   begin match system with

asmcomp/i386/proc.ml

@@ -207,6 +207,7 @@ let destroyed_at_oper = function
   | Iop(Iintop Imulh) -> [| eax |]
   | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |]
   | Iop(Iintoffloat) -> [| eax |]
+  | Iop(Ibeginregion|Iendregion) -> [| eax; ebx |]
   | Iifthenelse(Ifloattest _, _, _) -> [| eax |]
   | Itrywith _ -> [| edx |]
   | _ -> [||]
@@ -235,6 +236,7 @@ let op_is_pure = function
   | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false
   | Ispecific(Ilea _) -> true
   | Ispecific _ -> false
+  | Ibeginregion | Iendregion -> false
   | _ -> true
 
 (* Layout of the stack frame *)

runtime/i386.S

@@ -203,6 +203,41 @@ FUNCTION(caml_allocN)
         CFI_ENDPROC
         ENDFUNCTION(caml_allocN)
 
+FUNCTION(caml_call_local_realloc)
+        CFI_STARTPROC
+        movl    G(Caml_state), %ebx
+#if !defined(SYS_mingw) && !defined(SYS_cygwin)
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        subl    $(STACK_PROBE_SIZE), %esp; CFI_ADJUST(STACK_PROBE_SIZE);
+        movl    %eax, 0(%esp)
+        addl    $(STACK_PROBE_SIZE), %esp; CFI_ADJUST(-STACK_PROBE_SIZE);
+#endif
+    /* Build array of registers, save it into Caml_state->gc_regs */
+        pushl   %ebp; CFI_ADJUST(4)
+        pushl   %edi; CFI_ADJUST(4)
+        pushl   %esi; CFI_ADJUST(4)
+        pushl   %edx; CFI_ADJUST(4)
+        pushl   %ecx; CFI_ADJUST(4)
+        pushl   %ebx; CFI_ADJUST(4)
+        pushl   %eax; CFI_ADJUST(4)
+        movl    %esp, CAML_STATE(gc_regs, %ebx)
+        /* MacOSX note: 16-alignment of stack preserved at this point */
+    /* Call the garbage collector */
+        call    G(caml_local_realloc)
+    /* Restore all regs used by the code generator */
+        popl    %eax; CFI_ADJUST(-4)
+        popl    %ebx; CFI_ADJUST(-4)
+        popl    %ecx; CFI_ADJUST(-4)
+        popl    %edx; CFI_ADJUST(-4)
+        popl    %esi; CFI_ADJUST(-4)
+        popl    %edi; CFI_ADJUST(-4)
+        popl    %ebp; CFI_ADJUST(-4)
+        ret
+        CFI_ENDPROC
+        ENDFUNCTION(caml_call_local_realloc)
+
+
 /* Call a C function from OCaml */
 
 FUNCTION(caml_c_call)