Merge remote-tracking branch 'jane/local-reviewed' into local-merge

Author: stedolan

asmcomp/CSEgen.ml

@@ -237,6 +237,7 @@ method class_of_operation op =
   | Ispecific _ -> Op_other
   | Iname_for_debugger _ -> Op_pure
   | Iprobe_is_enabled _ -> Op_other
+  | Ibeginregion | Iendregion -> Op_other
 
 (* Operations that are so cheap that it isn't worth factoring them. *)
 

asmcomp/afl_instrument.ml

@@ -88,6 +88,8 @@ and instrument = function
      in
      Ccatch (isrec, cases, instrument body)
   | Cexit (ex, args) -> Cexit (ex, List.map instrument args)
+  | Cregion e -> Cregion (instrument e)
+  | Ctail e -> Ctail (instrument e)
 
   (* these are base cases and have no logging *)
   | Cconst_int _ | Cconst_natint _ | Cconst_float _

asmcomp/amd64/emit.mlp

@@ -299,6 +299,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
@@ -737,7 +750,7 @@ let emit_instr fallthrough i =
       | Double ->
           I.movsd (arg i 0) (addressing addr REAL8 i 1)
       end
-  | Lop(Ialloc { bytes = n; dbginfo }) ->
+  | Lop(Ialloc { bytes = n; dbginfo; mode = Alloc_heap }) ->
       assert (n <= (Config.max_young_wosize + 1) * Arch.size_addr);
       if !fastcode_flag then begin
         I.sub (int n) r15;
@@ -767,6 +780,21 @@ let emit_instr fallthrough i =
         def_label label;
         I.lea (mem64 NONE 8 R15) (res i 0)
       end
+  | Lop(Ialloc { bytes = n; dbginfo=_; mode = Alloc_local }) ->
+      let r = res i 0 in
+      I.mov (domain_field Domainstate.Domain_local_sp) r;
+      I.sub (int n) r;
+      I.mov r (domain_field Domainstate.Domain_local_sp);
+      I.cmp (domain_field Domainstate.Domain_local_limit) r;
+      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) r;
+      I.add (int 8) r;
+      local_realloc_sites :=
+        { lr_lbl = lbl_call;
+          lr_return_lbl = lbl_after_alloc } :: !local_realloc_sites
   | Lop(Iintop(Icomp cmp)) ->
       I.cmp (arg i 1) (arg i 0);
       I.set (cond cmp) al;
@@ -844,6 +872,14 @@ let emit_instr fallthrough i =
       I.movsxd (arg32 i 0) (res i 0)
   | Lop(Ispecific(Izextend32)) ->
       I.mov (arg32 i 0) (res32 i 0)
+  | 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.add (domain_field Domainstate.Domain_local_sp) r11;
+      I.mov r11 (domain_field Domainstate.Domain_local_sp)
   | Lop (Iname_for_debugger _) -> ()
   | Lop (Iprobe _) ->
     let probe_label = new_label () in
@@ -1026,6 +1062,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
@@ -1049,6 +1086,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 ();
   if !frame_required then begin
     let n = frame_size() - 8 - (if fp then 8 else 0) in

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 ! *)
@@ -358,6 +359,7 @@ let op_is_pure = function
   | Ispecific(Ilea _|Isextend32|Izextend32) -> true
   | Ispecific _ -> false
   | Iprobe _ | Iprobe_is_enabled _-> false
+  | Ibeginregion | Iendregion -> false
   | _ -> true
 
 (* Layout of the stack frame *)

asmcomp/arm/emit.mlp

@@ -636,7 +636,7 @@ let emit_instr i =
           | Double -> "fstd"
           | _ (* 32-bit quantities *) -> "str" in
         `	{emit_string instr}	{emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1
-    | Lop(Ialloc { bytes = n; dbginfo }) ->
+    | Lop(Ialloc { bytes = n; dbginfo; mode = Alloc_heap }) ->
         let lbl_frame =
           record_frame_label i.live (Dbg_alloc dbginfo)
         in
@@ -670,6 +670,8 @@ let emit_instr i =
           `{emit_label lbl_frame}:	add	{emit_reg i.res.(0)}, alloc_ptr, #4\n`;
           1 + ninstr
         end
+    | Lop(Ialloc { mode = Alloc_local } | Ibeginregion | Iendregion) ->
+       Misc.fatal_error "Local allocations not supported on this architecture"
     | Lop(Iintop(Icomp cmp)) ->
         `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         1 + emit_set_condition cmp i.res.(0)

asmcomp/arm64/emit.mlp

@@ -511,6 +511,8 @@ module BR = Branch_relaxation.Make (struct
       | 16 | 24 | 32 -> 1
       | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_bytes)
       end
+    | Lop (Ibeginregion | Iendregion) ->
+       Misc.fatal_error "Local allocations not supported on this architecture"
     | Lop (Iintop (Icomp _)) -> 2
     | Lop (Iintop_imm (Icomp _, _)) -> 2
     | Lop (Iintop (Icheckbound)) -> 2
@@ -771,10 +773,12 @@ let emit_instr i =
         | Word_int | Word_val | Double ->
             `	str	{emit_reg src}, {emit_addressing addr base}\n`
         end
-    | Lop(Ialloc { bytes = n; dbginfo }) ->
+    | Lop(Ialloc { bytes = n; dbginfo; mode = Alloc_heap }) ->
         assembly_code_for_allocation i ~n ~far:false ~dbginfo
     | Lop(Ispecific (Ifar_alloc { bytes = n; dbginfo })) ->
         assembly_code_for_allocation i ~n ~far:true ~dbginfo
+    | Lop(Ialloc { mode = Alloc_local } | Ibeginregion | Iendregion) ->
+       Misc.fatal_error "Local allocations not supported on this architecture"
     | Lop(Iintop_imm(Iadd, n)) ->
         emit_addimm i.res.(0) i.arg.(0) n
     | Lop(Iintop_imm(Isub, n)) ->

asmcomp/cmm.ml

@@ -148,10 +148,10 @@ type memory_chunk =
   | Double
 
 and operation =
-    Capply of machtype
+    Capply of machtype * Lambda.apply_position
   | Cextcall of string * machtype * exttype list * bool
   | Cload of memory_chunk * Asttypes.mutable_flag
-  | Calloc
+  | Calloc of Lambda.alloc_mode
   | Cstore of memory_chunk * Lambda.initialization_or_assignment
   | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
   | Cand | Cor | Cxor | Clsl | Clsr | Casr
@@ -195,6 +195,8 @@ type expression =
   | Cexit of int * expression list
   | Ctrywith of expression * Backend_var.With_provenance.t * expression
       * Debuginfo.t
+  | Cregion of expression
+  | Ctail of expression
 
 type codegen_option =
   | Reduce_code_size
@@ -254,6 +256,12 @@ let iter_shallow_tail f = function
       f e1;
       f e2;
       true
+  | Cregion e ->
+      f e;
+      true
+  | Ctail e ->
+      f e;
+      true
   | Cexit _ | Cop (Craise _, _, _) ->
       true
   | Cconst_int _
@@ -266,30 +274,34 @@ let iter_shallow_tail f = function
   | Cop _ ->
       false
 
-let rec map_tail f = function
+let map_shallow_tail f = function
   | Clet(id, exp, body) ->
-      Clet(id, exp, map_tail f body)
+      Clet(id, exp, f body)
   | Clet_mut(id, kind, exp, body) ->
-      Clet_mut(id, kind, exp, map_tail f body)
+      Clet_mut(id, kind, exp, f body)
   | Cphantom_let(id, exp, body) ->
-      Cphantom_let (id, exp, map_tail f body)
+      Cphantom_let (id, exp, f body)
   | Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) ->
       Cifthenelse
         (
           cond,
-          ifso_dbg, map_tail f ifso,
-          ifnot_dbg, map_tail f ifnot,
+          ifso_dbg, f ifso,
+          ifnot_dbg, f ifnot,
           dbg
         )
   | Csequence(e1, e2) ->
-      Csequence(e1, map_tail f e2)
+      Csequence(e1, f e2)
   | Cswitch(e, tbl, el, dbg') ->
-      Cswitch(e, tbl, Array.map (fun (e, dbg) -> map_tail f e, dbg) el, dbg')
+      Cswitch(e, tbl, Array.map (fun (e, dbg) -> f e, dbg) el, dbg')
   | Ccatch(rec_flag, handlers, body) ->
-      let map_h (n, ids, handler, dbg) = (n, ids, map_tail f handler, dbg) in
-      Ccatch(rec_flag, List.map map_h handlers, map_tail f body)
+      let map_h (n, ids, handler, dbg) = (n, ids, f handler, dbg) in
+      Ccatch(rec_flag, List.map map_h handlers, f body)
   | Ctrywith(e1, id, e2, dbg) ->
-      Ctrywith(map_tail f e1, id, map_tail f e2, dbg)
+      Ctrywith(f e1, id, f e2, dbg)
+  | Cregion e ->
+      Cregion(f e)
+  | Ctail e ->
+      Ctail(f e)
   | Cexit _ | Cop (Craise _, _, _) as cmm ->
       cmm
   | Cconst_int _
@@ -299,8 +311,59 @@ let rec map_tail f = function
   | Cvar _
   | Cassign _
   | Ctuple _
-  | Cop _ as c ->
-      f c
+  | Cop _ as cmm -> cmm
+
+let map_tail f =
+  let rec loop = function
+    | Cconst_int _
+    | Cconst_natint _
+    | Cconst_float _
+    | Cconst_symbol _
+    | Cvar _
+    | Cassign _
+    | Ctuple _
+    | Cop _ as c ->
+        f c
+    | cmm -> map_shallow_tail loop cmm
+  in
+  loop
+
+let iter_shallow f = function
+  | Clet (_id, e1, e2) ->
+      f e1; f e2
+  | Clet_mut (_id, _kind, e1, e2) ->
+      f e1; f e2
+  | Cphantom_let (_id, _de, e) ->
+      f e
+  | Cassign (_id, e) ->
+      f e
+  | Ctuple el ->
+      List.iter f el
+  | Cop (_op, el, _dbg) ->
+      List.iter f el
+  | Csequence (e1, e2) ->
+      f e1; f e2
+  | Cifthenelse(cond, _ifso_dbg, ifso, _ifnot_dbg, ifnot, _dbg) ->
+      f cond; f ifso; f ifnot
+  | Cswitch (_e, _ia, ea, _dbg) ->
+      Array.iter (fun (e, _) -> f e) ea
+  | Ccatch (_rf, hl, body) ->
+      let iter_h (_n, _ids, handler, _dbg) = f handler in
+      List.iter iter_h hl; f body
+  | Cexit (_n, el) ->
+      List.iter f el
+  | Ctrywith (e1, _id, e2, _dbg) ->
+      f e1; f e2
+  | Cregion e ->
+      f e
+  | Ctail e ->
+      f e
+  | Cconst_int _
+  | Cconst_natint _
+  | Cconst_float _
+  | Cconst_symbol _
+  | Cvar _ ->
+      ()
 
 let map_shallow f = function
   | Clet (id, e1, e2) ->
@@ -328,6 +391,10 @@ let map_shallow f = function
       Cexit (n, List.map f el)
   | Ctrywith (e1, id, e2, dbg) ->
       Ctrywith (f e1, id, f e2, dbg)
+  | Cregion e ->
+      Cregion (f e)
+  | Ctail e ->
+      Ctail (f e)
   | Cconst_int _
   | Cconst_natint _
   | Cconst_float _

asmcomp/cmm.mli

@@ -139,13 +139,13 @@ type memory_chunk =
                                           see PR#10433 *)
 
 and operation =
-    Capply of machtype
+    Capply of machtype * Lambda.apply_position
   | Cextcall of string * machtype * exttype list * bool
       (** The [machtype] is the machine type of the result.
           The [exttype list] describes the unboxing types of the arguments.
           An empty list means "all arguments are machine words [XInt]". *)
   | Cload of memory_chunk * Asttypes.mutable_flag
-  | Calloc
+  | Calloc of Lambda.alloc_mode
   | Cstore of memory_chunk * Lambda.initialization_or_assignment
   | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
   | Cand | Cor | Cxor | Clsl | Clsr | Casr
@@ -196,6 +196,8 @@ and expression =
   | Cexit of int * expression list
   | Ctrywith of expression * Backend_var.With_provenance.t * expression
       * Debuginfo.t
+  | Cregion of expression
+  | Ctail of expression
 
 type codegen_option =
   | Reduce_code_size
@@ -243,11 +245,18 @@ val iter_shallow_tail: (expression -> unit) -> expression -> bool
       considered to be in tail position (because their result become
       the final result for the expression).  *)
 
+val map_shallow_tail: (expression -> expression) -> expression -> expression
+  (** Apply the transformation to those immediate sub-expressions of an
+      expression that are in tail position, using the same definition of "tail"
+      as [iter_shallow_tail] *)
+
 val map_tail: (expression -> expression) -> expression -> expression
   (** Apply the transformation to an expression, trying to push it
-      to all inner sub-expressions that can produce the final result.
-      Same disclaimer as for [iter_shallow_tail] about the notion
-      of "tail" sub-expression. *)
+      to all inner sub-expressions that can produce the final result,
+      by recursively applying map_shallow_tail *)
+
+val iter_shallow: (expression -> unit) -> expression -> unit
+  (** Apply the transformation to each immediate sub-expression. *)
 
 val map_shallow: (expression -> expression) -> expression -> expression
   (** Apply the transformation to each immediate sub-expression. *)