Retain block-structured local regions until Mach.

Insertion of explicit endregion primitives now occurs in Selectgen,
rather than in Lambda. Early exit from regions (via static exceptions)
is now permitted, with endregions inserted where appropriate.

Author: stedolan

asmcomp/CSEgen.ml

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

asmcomp/afl_instrument.ml

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

asmcomp/amd64/CSE.ml

@@ -29,8 +29,6 @@ method! class_of_operation op =
     begin match spec with
     | Ilea _ | Isextend32 | Izextend32 -> Op_pure
     | Istore_int(_, _, is_asg) -> Op_store is_asg
-    | Iregionbegin -> Op_load
-    | Iregionend -> Op_store true
     | Ioffset_loc(_, _) -> Op_store true
     | Ifloatarithmem _ | Ifloatsqrtf _ -> Op_load
     | Ibswap _ | Isqrtf -> super#class_of_operation op

asmcomp/amd64/arch.ml

@@ -46,8 +46,6 @@ type specific_operation =
                                           extension *)
   | Izextend32                         (* 32 to 64 bit conversion with zero
                                           extension *)
-  | Iregionbegin
-  | Iregionend
 
 and float_operation =
     Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv
@@ -135,10 +133,6 @@ let print_specific_operation printreg op ppf arg =
       fprintf ppf "sextend32 %a" printreg arg.(0)
   | Izextend32 ->
       fprintf ppf "zextend32 %a" printreg arg.(0)
-  | Iregionbegin ->
-      fprintf ppf "iregionbegin"
-  | Iregionend ->
-      fprintf ppf "iregionend %a" printreg arg.(0)
 
 let win64 =
   match Config.system with

asmcomp/amd64/emit.mlp

@@ -754,9 +754,9 @@ 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(Ispecific(Iregionbegin)) ->
+  | Lop(Ibeginregion) ->
       I.mov (domain_field Domainstate.Domain_local_sp) (res i 0)
-  | Lop(Ispecific(Iregionend)) ->
+  | Lop(Iendregion) ->
       I.mov (arg i 0) (domain_field Domainstate.Domain_local_sp)
   | Lop (Iname_for_debugger _) -> ()
   | Lreloadretaddr ->

asmcomp/amd64/proc.ml

@@ -357,6 +357,7 @@ let op_is_pure = function
   | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false
   | Ispecific(Ilea _|Isextend32|Izextend32) -> true
   | Ispecific _ -> false
+  | Ibeginregion | Iendregion -> false
   | _ -> true
 
 (* Layout of the stack frame *)

asmcomp/amd64/selection.ml

@@ -245,8 +245,6 @@ method! select_operation op args dbg =
       Ispecific Izextend32, [arg]
     | _ -> super#select_operation op args dbg
     end
-  | Cbeginregion -> Ispecific Iregionbegin, args
-  | Cendregion -> Ispecific Iregionend, args
   | _ -> super#select_operation op args dbg
 
 (* Recognize float arithmetic with mem *)

asmcomp/cmm.ml

@@ -165,8 +165,6 @@ and operation =
   | Ccmpf of float_comparison
   | Craise of Lambda.raise_kind
   | Ccheckbound
-  | Cbeginregion
-  | Cendregion
 
 type expression =
     Cconst_int of int * Debuginfo.t
@@ -195,6 +193,7 @@ type expression =
   | Cexit of int * expression list
   | Ctrywith of expression * Backend_var.With_provenance.t * expression
       * Debuginfo.t
+  | Cregion of expression
 
 type codegen_option =
   | Reduce_code_size
@@ -254,6 +253,9 @@ let iter_shallow_tail f = function
       f e1;
       f e2;
       true
+  | Cregion e ->
+      f e;
+      true
   | Cexit _ | Cop (Craise _, _, _) ->
       true
   | Cconst_int _
@@ -290,6 +292,8 @@ let rec map_tail f = function
       Ccatch(rec_flag, List.map map_h handlers, map_tail f body)
   | Ctrywith(e1, id, e2, dbg) ->
       Ctrywith(map_tail f e1, id, map_tail f e2, dbg)
+  | Cregion e ->
+      Cregion(map_tail f e)
   | Cexit _ | Cop (Craise _, _, _) as cmm ->
       cmm
   | Cconst_int _
@@ -302,6 +306,41 @@ let rec map_tail f = function
   | Cop _ as c ->
       f c
 
+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
+  | Cconst_int _
+  | Cconst_natint _
+  | Cconst_float _
+  | Cconst_symbol _
+  | Cvar _ ->
+      ()
+
 let map_shallow f = function
   | Clet (id, e1, e2) ->
       Clet (id, f e1, f e2)
@@ -328,6 +367,8 @@ 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)
   | Cconst_int _
   | Cconst_natint _
   | Cconst_float _

asmcomp/cmm.mli

@@ -162,8 +162,6 @@ and operation =
                    then the index.
                    It results in a bounds error if the index is greater than
                    or equal to the bound. *)
-  | Cbeginregion
-  | Cendregion
 
 (** Every basic block should have a corresponding [Debuginfo.t] for its
     beginning. *)
@@ -195,6 +193,7 @@ and expression =
   | Cexit of int * expression list
   | Ctrywith of expression * Backend_var.With_provenance.t * expression
       * Debuginfo.t
+  | Cregion of expression
 
 type codegen_option =
   | Reduce_code_size
@@ -248,5 +247,8 @@ val map_tail: (expression -> expression) -> expression -> expression
       Same disclaimer as for [iter_shallow_tail] about the notion
       of "tail" sub-expression. *)
 
+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. *)

asmcomp/cmm_helpers.ml

@@ -1772,6 +1772,24 @@ let cache_public_method meths tag cache dbg =
     Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg),
               Cvar tagged)))))
 
+let region e =
+  (* [Cregion e] is equivalent to [e] if [e] contains no local allocs *)
+  let rec check_local_allocs = function
+    | Cregion _ ->
+       (* Assume any already-existing Cregion contains a local alloc.
+          This prevents O(n^2) behaviour with many nested regions *)
+       raise Exit
+    | Cop (Calloc Alloc_local, _, _)
+    | Cop ((Cextcall _ | Capply _), _, _) ->
+       raise Exit
+    | e ->
+       iter_shallow check_local_allocs e
+  in
+  match check_local_allocs e with
+  | () -> e
+  | exception Exit -> Cregion e
+
+
 (* CR mshinwell: These will be filled in by later pull requests. *)
 let placeholder_dbg () = Debuginfo.none
 let placeholder_fun_dbg ~human_name:_ = Debuginfo.none

asmcomp/cmm_helpers.mli

@@ -576,6 +576,9 @@ val send :
   Lambda.meth_kind -> expression -> expression -> expression list ->
   Debuginfo.t -> expression
 
+(** Construct [Cregion e], eliding some useless regions *)
+val region : expression -> expression
+
 (** Generic Cmm fragments *)
 
 (** Generate generic functions *)

asmcomp/cmmgen.ml

@@ -556,7 +556,7 @@ let rec transl env e =
          | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
          | Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _
          | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _
-         | Pbbswap _ | Pendregion), _)
+         | Pbbswap _), _)
         ->
           fatal_error "Cmmgen.transl:prim"
       end
@@ -672,8 +672,8 @@ let rec transl env e =
   | Uunreachable ->
       let dbg = Debuginfo.none in
       Cop(Cload (Word_int, Mutable), [Cconst_int (0, dbg)], dbg)
-  | Ubeginregion (r, e) ->
-      Clet (r, Cop (Cbeginregion, [], Debuginfo.none), transl env e)
+  | Uregion e ->
+      region (transl env e)
 
 and transl_catch env nfail ids body handler dbg =
   let ids = List.map (fun (id, kind) -> (id, kind, ref No_result)) ids in
@@ -846,8 +846,6 @@ and transl_prim_1 env p arg dbg =
   | Pbswap16 ->
       tag_int (bswap16 (ignore_high_bit_int (untag_int
         (transl env arg) dbg)) dbg) dbg
-  | Pendregion ->
-      Cop(Cendregion, [transl env arg], dbg)
   | (Pfield_computed | Psequand | Psequor
     | Paddint | Psubint | Pmulint | Pandint
     | Porint | Pxorint | Plslint | Plsrint | Pasrint
@@ -1041,7 +1039,7 @@ and transl_prim_2 env p arg1 arg2 dbg =
   | Pmakearray (_, _) | Pduparray (_, _) | Parraylength _ | Parraysetu _
   | Parraysets _ | Pbintofint _ | Pintofbint _ | Pcvtbint (_, _)
   | Pnegbint _ | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _)
-  | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _ | Pendregion
+  | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _
     ->
       fatal_errorf "Cmmgen.transl_prim_2: %a"
         Printclambda_primitives.primitive p
@@ -1100,7 +1098,7 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
   | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _
   | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _)
   | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _
-  | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _ | Pendregion
+  | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _
     ->
       fatal_errorf "Cmmgen.transl_prim_3: %a"
         Printclambda_primitives.primitive p

asmcomp/mach.ml

@@ -62,6 +62,7 @@ type operation =
   | Ispecific of Arch.specific_operation
   | Iname_for_debugger of { ident : Backend_var.t; which_parameter : int option;
       provenance : unit option; is_assignment : bool; }
+  | Ibeginregion | Iendregion
 
 type instruction =
   { desc: instruction_desc;

asmcomp/mach.mli

@@ -69,6 +69,7 @@ type operation =
         (b) If [is_assignment] is [true], any information about other [Reg.t]s
             that have been previously deemed to hold the value of that
             identifier is forgotten. *)
+  | Ibeginregion | Iendregion
 
 type instruction =
   { desc: instruction_desc;

asmcomp/printcmm.ml

@@ -157,8 +157,6 @@ let operation d = function
   | Ccmpf c -> Printf.sprintf "%sf" (float_comparison c)
   | Craise k -> Lambda.raise_kind k ^ location d
   | Ccheckbound -> "checkbound" ^ location d
-  | Cbeginregion -> "beginregion" ^ location d
-  | Cendregion -> "endregion" ^ location d
 
 let rec expr ppf = function
   | Cconst_int (n, _dbg) -> fprintf ppf "%i" n
@@ -268,6 +266,8 @@ let rec expr ppf = function
   | Ctrywith(e1, id, e2, _dbg) ->
       fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]"
              sequence e1 VP.print id sequence e2
+  | Cregion e ->
+      fprintf ppf "@[<2>(region@ %a)@]" sequence e
 
 and sequence ppf = function
   | Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2

asmcomp/printmach.ml

@@ -151,6 +151,8 @@ let operation op arg ppf res =
         | None -> ""
         | Some index -> sprintf "[P%d]" index)
       reg arg.(0)
+  | Ibeginregion -> fprintf ppf "beginregion"
+  | Iendregion -> fprintf ppf "endregion %a" reg arg.(0)
   | Ispecific op ->
       Arch.print_specific_operation reg op ppf arg