CMM traps

backend/CSEgen.ml

@@ -213,6 +213,17 @@ let insert_move srcs dsts i =
          let i1 = array_fold2 insert_single_move i tmps dsts in
          array_fold2 insert_single_move i1 srcs tmps
 
+let rec split3 = function
+    [] -> ([], [], [])
+  | (x,y,z)::l ->
+    let (rx, ry, rz) = split3 l in (x::rx, y::ry, z::rz)
+
+let rec combine3 l1 l2 l3 =
+  match (l1, l2, l3) with
+    ([], [], []) -> []
+  | (a1::l1, a2::l2, a3::l3) -> (a1, a2, a3) :: combine3 l1 l2 l3
+  | (_, _, _) -> invalid_arg "combine3"
+
 class cse_generic = object (self)
 
 (* Default classification of operations.  Can be overridden in
@@ -256,7 +267,7 @@ method private kill_loads n =
 
 method private cse n i k =
   match i.desc with
-  | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _)
+  | Iend | Ireturn _ | Iop(Itailcall_ind) | Iop(Itailcall_imm _)
   | Iexit _ | Iraise _ ->
       k i
   | Iop (Imove | Ispill | Ireload) ->
@@ -352,18 +363,18 @@ method private cse n i k =
       self#cse_array n1 cases (fun cases ->
         self#cse empty_numbering i.next (fun next ->
           k { i with desc = Iswitch(index, cases); next; }))
-  | Icatch(rec_flag, handlers, body) ->
-      let nfail, handler_code = List.split handlers in
+  | Icatch(rec_flag, ts, handlers, body) ->
+      let nfail, t, handler_code = split3 handlers in
       self#cse_list empty_numbering handler_code (fun handler_code ->
-        let handlers = List.combine nfail handler_code in
+        let handlers = combine3 nfail t handler_code in
         self#cse n body (fun body ->
           self#cse empty_numbering i.next (fun next ->
-            k { i with desc = Icatch(rec_flag, handlers, body); next; })))
-  | Itrywith(body, handler) ->
+            k { i with desc = Icatch(rec_flag, ts, handlers, body); next; })))
+  | Itrywith(body, kind, (ts, handler)) ->
       self#cse n body (fun body ->
         self#cse empty_numbering handler (fun handler ->
           self#cse empty_numbering i.next (fun next ->
-            k { i with desc = Itrywith(body, handler); next; })))
+            k { i with desc = Itrywith(body, kind, (ts, handler)); next; })))
 
 method private cse_array n is k =
   self#cse_list n (Array.to_list is) (fun is -> k (Array.of_list is))

backend/afl_instrument.ml

@@ -60,8 +60,8 @@ and instrument = function
   | Cifthenelse (cond, t_dbg, t, f_dbg, f, dbg) ->
      Cifthenelse (instrument cond, t_dbg, with_afl_logging t t_dbg,
        f_dbg, with_afl_logging f f_dbg, dbg)
-  | Ctrywith (e, ex, handler, dbg) ->
-     Ctrywith (instrument e, ex, with_afl_logging handler dbg, dbg)
+  | Ctrywith (e, kind, ex, handler, dbg) ->
+     Ctrywith (instrument e, kind, ex, with_afl_logging handler dbg, dbg)
   | Cswitch (e, cases, handlers, dbg) ->
      let handlers =
        Array.map (fun (handler, handler_dbg) ->
@@ -87,7 +87,7 @@ and instrument = function
          cases
      in
      Ccatch (isrec, cases, instrument body)
-  | Cexit (ex, args) -> Cexit (ex, List.map instrument args)
+  | Cexit (ex, args, traps) -> Cexit (ex, List.map instrument args, traps)
 
   (* these are base cases and have no logging *)
   | Cconst_int _ | Cconst_natint _ | Cconst_float _

backend/amd64/proc.ml

@@ -330,7 +330,7 @@ let destroyed_at_oper = function
        | Iconst_int _ | Iconst_float _ | Iconst_symbol _
        | Itailcall_ind | Itailcall_imm _ | Istackoffset _ | Iload (_, _)
        | Iname_for_debugger _ | Iprobe _| Iprobe_is_enabled _)
-  | Iend | Ireturn | Iifthenelse (_, _, _) | Icatch (_, _, _)
+  | Iend | Ireturn _ | Iifthenelse (_, _, _) | Icatch (_, _, _, _)
   | Iexit _ | Iraise _
     ->
     if fp then

backend/amd64/selection.ml

@@ -210,7 +210,7 @@ method! select_store is_assign addr exp =
   | Cvar _ | Clet (_, _, _) | Clet_mut (_, _, _, _) | Cphantom_let (_, _, _)
   | Cassign (_, _) | Ctuple _ | Cop (_, _, _) | Csequence (_, _)
   | Cifthenelse (_, _, _, _, _, _) | Cswitch (_, _, _, _) | Ccatch (_, _, _)
-  | Cexit (_, _) | Ctrywith (_, _, _, _)
+  | Cexit (_, _, _) | Ctrywith (_, _, _, _, _)
     ->
       super#select_store is_assign addr exp
 

backend/cmm.ml

@@ -109,6 +109,10 @@ let negate_float_comparison = Lambda.negate_float_comparison
 let swap_float_comparison = Lambda.swap_float_comparison
 type label = int
 
+type exit_label =
+  | Return_lbl
+  | Lbl of label
+
 let init_label = 99
 
 let label_counter = ref init_label
@@ -138,6 +142,16 @@ type phantom_defining_expr =
   | Cphantom_read_symbol_field of { sym : string; field : int; }
   | Cphantom_block of { tag : int; fields : Backend_var.t list; }
 
+type trywith_shared_label = int
+
+type trap_action =
+  | Push of trywith_shared_label
+  | Pop
+
+type trywith_kind =
+  | Regular
+  | Delayed of trywith_shared_label
+
 type memory_chunk =
     Byte_unsigned
   | Byte_signed
@@ -202,12 +216,12 @@ type expression =
       * Debuginfo.t
   | Ccatch of
       rec_flag
-        * (int * (Backend_var.With_provenance.t * machtype) list
+        * (label * (Backend_var.With_provenance.t * machtype) list
           * expression * Debuginfo.t) list
         * expression
-  | Cexit of int * expression list
-  | Ctrywith of expression * Backend_var.With_provenance.t * expression
-      * Debuginfo.t
+  | Cexit of exit_label * expression list * trap_action list
+  | Ctrywith of expression * trywith_kind * Backend_var.With_provenance.t
+      * expression * Debuginfo.t
 
 type codegen_option =
   | Reduce_code_size
@@ -263,7 +277,7 @@ let iter_shallow_tail f = function
       List.iter (fun (_, _, h, _dbg) -> f h) handlers;
       f body;
       true
-  | Ctrywith(e1, _id, e2, _dbg) ->
+  | Ctrywith(e1, _kind, _id, e2, _dbg) ->
       f e1;
       f e2;
       true
@@ -301,8 +315,8 @@ let rec map_tail f = function
   | 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)
-  | Ctrywith(e1, id, e2, dbg) ->
-      Ctrywith(map_tail f e1, id, map_tail f e2, dbg)
+  | Ctrywith(e1, kind, id, e2, dbg) ->
+      Ctrywith(map_tail f e1, kind, id, map_tail f e2, dbg)
   | Cexit _ | Cop (Craise _, _, _) as cmm ->
       cmm
   | Cconst_int _
@@ -337,10 +351,10 @@ let map_shallow f = function
   | Ccatch (rf, hl, body) ->
       let map_h (n, ids, handler, dbg) = (n, ids, f handler, dbg) in
       Ccatch (rf, List.map map_h hl, f body)
-  | Cexit (n, el) ->
-      Cexit (n, List.map f el)
-  | Ctrywith (e1, id, e2, dbg) ->
-      Ctrywith (f e1, id, f e2, dbg)
+  | Cexit (n, el, traps) ->
+      Cexit (n, List.map f el, traps)
+  | Ctrywith (e1, kind, id, e2, dbg) ->
+      Ctrywith (f e1, kind, id, f e2, dbg)
   | Cconst_int _
   | Cconst_natint _
   | Cconst_float _

backend/cmm.mli

@@ -96,6 +96,10 @@ val new_label: unit -> label
 val set_label: label -> unit
 val cur_label: unit -> label
 
+type exit_label =
+  | Return_lbl
+  | Lbl of label
+
 type rec_flag = Nonrecursive | Recursive
 
 type effects = No_effects | Arbitrary_effects
@@ -128,6 +132,24 @@ type phantom_defining_expr =
   (** The phantom-let-bound variable points at a block with the given
       structure. *)
 
+type trywith_shared_label = int (* Same as Ccatch handlers *)
+
+type trap_action =
+  | Push of trywith_shared_label
+  (** Add the corresponding handler to the trap stack. *)
+  | Pop
+  (** Remove the last handler from the trap stack. *)
+
+type trywith_kind =
+  | Regular
+  (** Regular trywith: an uncaught exception from the body will always be
+      handled by this handler. *)
+  | Delayed of trywith_shared_label
+  (** The body starts with the previous exception handler, and only after going
+      through an explicit Push-annotated Cexit will this handler become active.
+      This allows for sharing a single handler in several places, or having
+      multiple entry and exit points to a single trywith block. *)
+
 type memory_chunk =
     Byte_unsigned
   | Byte_signed
@@ -203,12 +225,12 @@ and expression =
       * Debuginfo.t
   | Ccatch of
       rec_flag
-        * (int * (Backend_var.With_provenance.t * machtype) list
+        * (label * (Backend_var.With_provenance.t * machtype) list
           * expression * Debuginfo.t) list
         * expression
-  | Cexit of int * expression list
-  | Ctrywith of expression * Backend_var.With_provenance.t * expression
-      * Debuginfo.t
+  | Cexit of exit_label * expression list * trap_action list
+  | Ctrywith of expression * trywith_kind * Backend_var.With_provenance.t
+      * expression * Debuginfo.t
 
 type codegen_option =
   | Reduce_code_size
@@ -241,7 +263,7 @@ type phrase =
   | Cdata of data_item list
 
 val ccatch :
-     int * (Backend_var.With_provenance.t * machtype) list
+     label * (Backend_var.With_provenance.t * machtype) list
        * expression * expression * Debuginfo.t
   -> expression
 

backend/cmm_helpers.ml

@@ -319,7 +319,7 @@ let mk_compare_floats dbg a1 a2 =
 
 let create_loop body dbg =
   let cont = Lambda.next_raise_count () in
-  let call_cont = Cexit (cont, []) in
+  let call_cont = Cexit (Lbl cont, [], []) in
   let body = Csequence (body, call_cont) in
   Ccatch (Recursive, [cont, [], body, dbg], call_cont)
 
@@ -605,15 +605,15 @@ let rec remove_unit = function
   | Ccatch(rec_flag, handlers, body) ->
       let map_h (n, ids, handler, dbg) = (n, ids, remove_unit handler, dbg) in
       Ccatch(rec_flag, List.map map_h handlers, remove_unit body)
-  | Ctrywith(body, exn, handler, dbg) ->
-      Ctrywith(remove_unit body, exn, remove_unit handler, dbg)
+  | Ctrywith(body, kind, exn, handler, dbg) ->
+    Ctrywith(remove_unit body, kind, exn, remove_unit handler, dbg)
   | Clet(id, c1, c2) ->
       Clet(id, c1, remove_unit c2)
   | Cop(Capply _mty, args, dbg) ->
       Cop(Capply typ_void, args, dbg)
   | Cop(Cextcall c, args, dbg) ->
       Cop(Cextcall {c with ret = typ_void; }, args, dbg)
-  | Cexit (_,_) as c -> c
+  | Cexit (_,_,_) as c -> c
   | Ctuple [] as c -> c
   | c -> Csequence(c, Ctuple [])
 
@@ -1541,7 +1541,7 @@ struct
   let bind arg body = bind "switcher" arg body
 
   let make_catch handler = match handler with
-  | Cexit (i,[]) -> i,fun e -> e
+  | Cexit (Lbl i,[],[]) -> i,fun e -> e
   | _ ->
       let dbg = Debuginfo.none in
       let i = Lambda.next_raise_count () in
@@ -1552,12 +1552,12 @@ struct
 *)
       i,
       (fun body -> match body with
-      | Cexit (j,_) ->
-          if i=j then handler
+      | Cexit (j,_,_) ->
+          if Lbl i = j then handler
           else body
       | _ ->  ccatch (i,[],body,handler, dbg))
 
-  let make_exit i = Cexit (i,[])
+  let make_exit i = Cexit (Lbl i,[],[])
 
 end
 
@@ -1576,7 +1576,7 @@ module StoreExpForSwitch =
       let make_key index expr =
         let continuation =
           match expr with
-          | Cexit (i,[]) -> Some i
+          | Cexit (Lbl i,[],[]) -> Some i
           | _ -> None
         in
         Some (continuation, index)
@@ -1593,7 +1593,7 @@ module StoreExp =
       type t = expression
       type key = int
       let make_key = function
-        | Cexit (i,[]) -> Some i
+        | Cexit (Lbl i,[],[]) -> Some i
         | _ -> None
       let compare_key = Stdlib.compare
     end)
@@ -1778,7 +1778,7 @@ let cache_public_method meths tag cache dbg =
            dbg),
         Cifthenelse
           (Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg),
-           dbg, Cexit (raise_num, []),
+           dbg, Cexit (Lbl raise_num, [], []),
            dbg, Ctuple [],
            dbg))))
        dbg,