flambda-backend: Backend support for local allocations (#478)

Adds local allocations (Ialloc Alloc_local) to the backend, as well
as new primitives for region boundaries (Ibeginregion/Iendregion).

In Cmm, instead of explicit Ibeginregion/Iendregion, there is a new
block-structured Cregion.

Since tail calls are supposed to end a region before transferring
control, Cmm also has two new constructs that end a region early:
Capply with Apply_tail, and Ctail (for general code blocks, resulting
from tail calls that have been inlined).

Author: stedolan

asmcomp/cmm_helpers.ml

@@ -2180,6 +2180,7 @@ let assignment_kind
     (ptr: Lambda.immediate_or_pointer)
     (init: Lambda.initialization_or_assignment) =
   match init, ptr with
+  | Local_assignment, _ -> assert false (* temporary *)
   | Assignment, Pointer -> Caml_modify
   | Heap_initialization, Pointer -> Caml_initialize
   | Assignment, Immediate

asmcomp/printcmm.ml

@@ -126,6 +126,7 @@ let operation d = function
       | Lambda.Heap_initialization -> "(heap-init)"
       | Lambda.Root_initialization -> "(root-init)"
       | Lambda.Assignment -> ""
+      | Lambda.Local_assignment -> "(local)"
     in
     Printf.sprintf "store %s%s" (chunk c) init
   | Caddi -> "+"

asmcomp/selectgen.ml

@@ -456,7 +456,7 @@ method select_operation op args _dbg =
         match init with
         | Lambda.Root_initialization -> false
         | Lambda.Heap_initialization -> false
-        | Lambda.Assignment -> true
+        | Lambda.Assignment | Lambda.Local_assignment -> true
       in
       if chunk = Word_int || chunk = Word_val then begin
         let (op, newarg2) = self#select_store is_assign addr arg2 in

lambda/lambda.ml

@@ -34,6 +34,7 @@ type immediate_or_pointer =
 
 type initialization_or_assignment =
   | Assignment
+  | Local_assignment
   | Heap_initialization
   | Root_initialization
 
@@ -45,6 +46,14 @@ type field_read_semantics =
   | Reads_agree
   | Reads_vary
 
+type alloc_mode =
+  | Alloc_heap
+  | Alloc_local
+
+type region_close =
+  | Rc_close_at_apply
+  | Rc_normal
+
 type primitive =
   | Pidentity
   | Pbytes_to_string
@@ -1005,3 +1014,21 @@ let mod_field ?(read_semantics=Reads_agree) pos =
 
 let mod_setfield pos =
   Psetfield (pos, Pointer, Root_initialization)
+
+let join_mode a b =
+  match a, b with
+  | Alloc_local, _ | _, Alloc_local -> Alloc_local
+  | Alloc_heap, Alloc_heap -> Alloc_heap
+
+let sub_mode a b =
+  match a, b with
+  | Alloc_heap, _ -> true
+  | _, Alloc_local -> true
+  | Alloc_local, Alloc_heap -> false
+
+let eq_mode a b =
+  match a, b with
+  | Alloc_heap, Alloc_heap -> true
+  | Alloc_local, Alloc_local -> true
+  | Alloc_heap, Alloc_local -> false
+  | Alloc_local, Alloc_heap -> false

lambda/lambda.mli

@@ -36,6 +36,7 @@ type immediate_or_pointer =
 
 type initialization_or_assignment =
   | Assignment
+  | Local_assignment (* mutations of blocks that may be locally allocated *)
   (* Initialization of in heap values, like [caml_initialize] C primitive.  The
      field should not have been read before and initialization should happen
      only once. *)
@@ -52,6 +53,14 @@ type field_read_semantics =
   | Reads_agree
   | Reads_vary
 
+type alloc_mode =
+  | Alloc_heap
+  | Alloc_local
+
+type region_close =
+  | Rc_close_at_apply
+  | Rc_normal
+
 type primitive =
   | Pidentity
   | Pbytes_to_string
@@ -461,6 +470,10 @@ val max_arity : unit -> int
       This is unlimited ([max_int]) for bytecode, but limited
       (currently to 126) for native code. *)
 
+val join_mode : alloc_mode -> alloc_mode -> alloc_mode
+val sub_mode : alloc_mode -> alloc_mode -> bool
+val eq_mode : alloc_mode -> alloc_mode -> bool
+
 (***********************)
 (* For static failures *)
 (***********************)

lambda/printlambda.ml

@@ -217,6 +217,7 @@ let primitive ppf = function
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfield_%s%s %i" instr init n
   | Psetfield_computed (ptr, init) ->
@@ -230,6 +231,7 @@ let primitive ppf = function
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfield_%s%s_computed" instr init
   | Pfloatfield (n, sem) ->
@@ -240,6 +242,7 @@ let primitive ppf = function
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfloatfield%s %i" init n
   | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size

middle_end/closure/closure.ml

@@ -121,7 +121,7 @@ let prim_size prim args =
   | Psetfield(_f, isptr, init) ->
     begin match init with
     | Root_initialization -> 1  (* never causes a write barrier hit *)
-    | Assignment | Heap_initialization ->
+    | Assignment | Local_assignment | Heap_initialization ->
       match isptr with
       | Pointer -> 4
       | Immediate -> 1

middle_end/flambda/inlining_cost.ml

@@ -26,7 +26,7 @@ let prim_size (prim : Clambda_primitives.primitive) args =
   | Psetfield (_, isptr, init) ->
     begin match init with
     | Root_initialization -> 1  (* never causes a write barrier hit *)
-    | Assignment | Heap_initialization ->
+    | Assignment | Local_assignment | Heap_initialization ->
       match isptr with
       | Pointer -> 4
       | Immediate -> 1

middle_end/printclambda_primitives.ml

@@ -75,6 +75,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfield_%s%s %i" instr init n
   | Psetfield_computed (ptr, init) ->
@@ -88,6 +89,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfield_%s%s_computed" instr init
   | Pfloatfield n -> fprintf ppf "floatfield %i" n
@@ -97,6 +99,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfloatfield%s %i" init n
   | Pduprecord (rep, size) ->

runtime/caml/domain_state.tbl

@@ -36,6 +36,11 @@ DOMAIN_STATE(struct caml_ephe_ref_table*, ephe_ref_table)
 DOMAIN_STATE(struct caml_custom_table*, custom_table)
 /* See minor_gc.c */
 
+DOMAIN_STATE(struct caml_local_arenas*, local_arenas)
+DOMAIN_STATE(intnat, local_sp)
+DOMAIN_STATE(void*, local_top)
+DOMAIN_STATE(intnat, local_limit)
+
 DOMAIN_STATE(struct mark_stack*, mark_stack)
 /* See major_gc.c */
 

runtime/domain.c

@@ -56,6 +56,11 @@ void caml_init_domain ()
   Caml_state->external_raise = NULL;
   Caml_state->exn_bucket = Val_unit;
 
+  Caml_state->local_arenas = NULL;
+  Caml_state->local_sp = 0;
+  Caml_state->local_top = NULL;
+  Caml_state->local_limit = 0;
+
   Caml_state->top_of_stack = NULL;
   Caml_state->bottom_of_stack = NULL; /* no stack initially */
   Caml_state->last_return_address = 1; /* not in OCaml code initially */