Cold continuation handlers in flambda2 (ocaml-flambda#1543)

backend/CSEgen.ml

@@ -214,16 +214,16 @@ 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 split4 = function
+    [] -> ([], [], [], [])
+  | (x,y,z,w)::l ->
+    let (rx, ry, rz, rw) = split4 l in (x::rx, y::ry, z::rz, w::rw)
 
-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"
+let rec combine4 l1 l2 l3 l4 =
+  match (l1, l2, l3, l4) with
+    ([], [], [], []) -> []
+  | (a1::l1, a2::l2, a3::l3, a4::l4) -> (a1, a2, a3, a4) :: combine4 l1 l2 l3 l4
+  | (_, _, _, _) -> invalid_arg "combine4"
 
 class cse_generic = object (self)
 
@@ -372,9 +372,9 @@ method private cse n i k =
         self#cse empty_numbering i.next (fun next ->
           k { i with desc = Iswitch(index, cases); next; }))
   | Icatch(rec_flag, ts, handlers, body) ->
-      let nfail, t, handler_code = split3 handlers in
+      let nfail, t, handler_code, is_cold = split4 handlers in
       self#cse_list empty_numbering handler_code (fun handler_code ->
-        let handlers = combine3 nfail t handler_code in
+        let handlers = combine4 nfail t handler_code is_cold in
         self#cse n body (fun body ->
           self#cse empty_numbering i.next (fun next ->
             k { i with desc = Icatch(rec_flag, ts, handlers, body); next; })))

backend/afl_instrument.ml

@@ -84,7 +84,8 @@ and instrument = function
   | Csequence (e1, e2) -> Csequence (instrument e1, instrument e2)
   | Ccatch (isrec, cases, body, kind) ->
      let cases =
-       List.map (fun (nfail, ids, e, dbg) -> nfail, ids, instrument e, dbg)
+       List.map (fun (nfail, ids, e, dbg, is_cold) ->
+           nfail, ids, instrument e, dbg, is_cold)
          cases
      in
      Ccatch (isrec, cases, instrument body, kind)

backend/cfg/cfgize.ml

@@ -565,7 +565,7 @@ let rec add_blocks :
     | Icatch (_rec, _trap_stack, handlers, body) ->
       let handlers =
         List.map
-          (fun (handler_id, _trap_stack, handler) ->
+          (fun (handler_id, _trap_stack, handler, _is_cold) ->
             let handler_label = State.add_catch_handler state ~handler_id in
             handler_label, handler)
           handlers

backend/cmm.ml

@@ -277,7 +277,7 @@ type expression =
   | Ccatch of
       rec_flag
         * (static_label * (Backend_var.With_provenance.t * machtype) list
-          * expression * Debuginfo.t) list
+          * expression * Debuginfo.t * bool (* is_cold *)) list
         * expression * kind_for_unboxing
   | Cexit of exit_label * expression list * trap_action list
   | Ctrywith of expression * trywith_kind * Backend_var.With_provenance.t
@@ -323,8 +323,8 @@ type phrase =
     Cfunction of fundecl
   | Cdata of data_item list
 
-let ccatch (i, ids, e1, e2, dbg, kind) =
-  Ccatch(Nonrecursive, [i, ids, e2, dbg], e1, kind)
+let ccatch (i, ids, e1, e2, dbg, kind, is_cold) =
+  Ccatch(Nonrecursive, [i, ids, e2, dbg, is_cold], e1, kind)
 
 let reset () =
   label_counter := init_label
@@ -344,7 +344,7 @@ let iter_shallow_tail f = function
       Array.iter (fun (e, _dbg) -> f e) el;
       true
   | Ccatch(_rec_flag, handlers, body, _value_kind) ->
-      List.iter (fun (_, _, h, _dbg) -> f h) handlers;
+      List.iter (fun (_, _, h, _dbg, _) -> f h) handlers;
       f body;
       true
   | Ctrywith(e1, _kind, _id, e2, _dbg, _value_kind) ->
@@ -388,7 +388,9 @@ let map_shallow_tail ?kind f = function
       Cswitch(e, tbl, Array.map (fun (e, dbg) -> f e, dbg) el, dbg',
               Option.value kind ~default:kind_before)
   | Ccatch(rec_flag, handlers, body, kind_before) ->
-      let map_h (n, ids, handler, dbg) = (n, ids, f handler, dbg) in
+      let map_h (n, ids, handler, dbg, is_cold) =
+        (n, ids, f handler, dbg, is_cold)
+      in
       Ccatch(rec_flag, List.map map_h handlers, f body,
              Option.value kind ~default:kind_before)
   | Ctrywith(e1, kind', id, e2, dbg, kind_before) ->
@@ -445,7 +447,7 @@ let iter_shallow f = function
   | Cswitch (_e, _ia, ea, _dbg, _value_kind) ->
       Array.iter (fun (e, _) -> f e) ea
   | Ccatch (_rf, hl, body, _value_kind) ->
-      let iter_h (_n, _ids, handler, _dbg) = f handler in
+      let iter_h (_n, _ids, handler, _dbg, _is_cold) = f handler in
       List.iter iter_h hl; f body
   | Cexit (_n, el, _traps) ->
       List.iter f el
@@ -483,7 +485,9 @@ let map_shallow f = function
   | Cswitch (e, ia, ea, dbg, kind) ->
       Cswitch (e, ia, Array.map (fun (e, dbg) -> f e, dbg) ea, dbg, kind)
   | Ccatch (rf, hl, body, kind) ->
-      let map_h (n, ids, handler, dbg) = (n, ids, f handler, dbg) in
+      let map_h (n, ids, handler, dbg, is_cold) =
+        (n, ids, f handler, dbg, is_cold)
+      in
       Ccatch (rf, List.map map_h hl, f body, kind)
   | Cexit (n, el, traps) ->
       Cexit (n, List.map f el, traps)

backend/cmm.mli

@@ -289,7 +289,7 @@ type expression =
   | Ccatch of
       rec_flag
         * (Lambda.static_label * (Backend_var.With_provenance.t * machtype) list
-          * expression * Debuginfo.t) list
+          * expression * Debuginfo.t * bool (* is_cold *)) list
         * expression
         * kind_for_unboxing
   | Cexit of exit_label * expression list * trap_action list
@@ -340,6 +340,7 @@ type phrase =
 val ccatch :
      label * (Backend_var.With_provenance.t * machtype) list
        * expression * expression * Debuginfo.t * kind_for_unboxing
+       * bool
   -> expression
 
 val reset : unit -> unit

backend/cmm_helpers.ml

@@ -424,7 +424,7 @@ let create_loop body dbg =
   let cont = Lambda.next_raise_count () in
   let call_cont = Cexit (Lbl cont, [], []) in
   let body = Csequence (body, call_cont) in
-  Ccatch (Recursive, [cont, [], body, dbg], call_cont, Any)
+  Ccatch (Recursive, [cont, [], body, dbg, false], call_cont, Any)
 
 (* Turning integer divisions into multiply-high then shift. The
    [division_parameters] function is used in module Emit for those target
@@ -773,7 +773,9 @@ let rec remove_unit = function
         dbg,
         kind )
   | Ccatch (rec_flag, handlers, body, kind) ->
-    let map_h (n, ids, handler, dbg) = n, ids, remove_unit handler, dbg in
+    let map_h (n, ids, handler, dbg, is_cold) =
+      n, ids, remove_unit handler, dbg, is_cold
+    in
     Ccatch (rec_flag, List.map map_h handlers, remove_unit body, kind)
   | Ctrywith (body, kind, exn, handler, dbg, value_kind) ->
     Ctrywith (remove_unit body, kind, exn, remove_unit handler, dbg, value_kind)
@@ -2191,7 +2193,7 @@ module SArgBlocks = struct
         fun body ->
           match body with
           | Cexit (j, _, _) -> if Lbl i = j then handler else body
-          | _ -> ccatch (i, [], body, handler, dbg, kind) ))
+          | _ -> ccatch (i, [], body, handler, dbg, kind, false) ))
 
   let make_exit i = Cexit (Lbl i, [], [])
 end
@@ -2475,7 +2477,8 @@ let cache_public_method meths tag cache dbg =
                     dbg,
                   Ctuple [],
                   dbg,
-                  Any ),
+                  Any,
+                  false ),
               Clet
                 ( VP.create tagged,
                   Cop
@@ -3862,7 +3865,8 @@ let entry_point namelist =
               dbg,
             Ctuple [],
             dbg,
-            Any ) )
+            Any,
+            false ) )
   in
   let fun_name = global_symbol "caml_program" in
   let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
@@ -4151,8 +4155,9 @@ type static_handler =
   * (Backend_var.With_provenance.t * Cmm.machtype) list
   * Cmm.expression
   * Debuginfo.t
+  * bool
 
-let handler ~dbg id vars body = id, vars, body, dbg
+let handler ~dbg id vars body is_cold = id, vars, body, dbg, is_cold
 
 let cexit id args trap_actions = Cmm.Cexit (Cmm.Lbl id, args, trap_actions)
 

backend/cmm_helpers.mli

@@ -1053,13 +1053,14 @@ val trywith :
 (** Opaque type for static handlers. *)
 type static_handler
 
-(** [handler id vars body] creates a static handler for exit number [id],
+(** [handler id vars body is_cold] creates a static handler for exit number [id],
     binding variables [vars] in [body]. *)
 val handler :
   dbg:Debuginfo.t ->
   Lambda.static_label ->
   (Backend_var.With_provenance.t * Cmm.machtype) list ->
   Cmm.expression ->
+  bool ->
   static_handler
 
 (** [cexit id args] creates the cmm expression for static to a static handler

backend/cmm_invariants.ml

@@ -155,7 +155,7 @@ let rec check env (expr : Cmm.expression) =
   | Ccatch (rec_flag, handlers, body, _) ->
     let env_extended =
       List.fold_left
-        (fun env (cont, args, _, _) ->
+        (fun env (cont, args, _, _, _) ->
            Env.handler env ~cont ~arg_num:(List.length args))
         env
         handlers
@@ -166,7 +166,7 @@ let rec check env (expr : Cmm.expression) =
       | Recursive -> env_extended
       | Nonrecursive -> env
     in
-    List.iter (fun (_, _, handler, _) -> check env_handler handler) handlers
+    List.iter (fun (_, _, handler, _, _) -> check env_handler handler) handlers
   | Cexit (exit_label, args, _trap_actions) ->
     Env.jump env ~exit_label ~arg_num:(List.length args)
   | Ctrywith (body, _trywith_kind, _, handler, _, _) ->

backend/cmmgen.ml

@@ -471,7 +471,7 @@ let rec is_unboxed_number_cmm = function
       List.fold_left
         (join_unboxed_number_kind ~strict)
         (is_unboxed_number_cmm body)
-        (List.map (fun (_, _, e, _) -> is_unboxed_number_cmm e) handlers)
+        (List.map (fun (_, _, e, _, _) -> is_unboxed_number_cmm e) handlers)
 
 (* Translate an expression *)
 
@@ -796,7 +796,7 @@ let rec transl env e =
                     )
               dbg,
             Ctuple [],
-            dbg, Any))
+            dbg, Any, false))
   | Ufor(id, low, high, dir, body) ->
       let dbg = Debuginfo.none in
       let tst = match dir with Upto -> Cgt   | Downto -> Clt in
@@ -831,7 +831,7 @@ let rec transl env e =
                       dbg,
                    dbg, Any),
                  Ctuple [],
-                 dbg, Any))))
+                 dbg, Any, false))))
   | Uassign(id, exp) ->
       let dbg = Debuginfo.none in
       let cexp = transl env exp in
@@ -882,7 +882,7 @@ and transl_catch (kind : Cmm.kind_for_unboxing) env nfail ids body handler dbg =
   in
   if env == new_env then
     (* No unboxing *)
-    ccatch (nfail, ids, body, transl env handler, dbg, kind)
+    ccatch (nfail, ids, body, transl env handler, dbg, kind, false)
   else
     (* allocate new "nfail" to catch errors more easily *)
     let new_nfail = next_raise_count () in
@@ -896,7 +896,7 @@ and transl_catch (kind : Cmm.kind_for_unboxing) env nfail ids body handler dbg =
       in
       aux body
     in
-    ccatch (new_nfail, ids, body, transl new_env handler, dbg, kind)
+    ccatch (new_nfail, ids, body, transl new_env handler, dbg, kind, false)
 
 and transl_make_array dbg env kind mode args =
   match kind with
@@ -1385,7 +1385,7 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body =
 and make_catch (kind : Cmm.kind_for_unboxing) ncatch body handler dbg =
   match body with
   | Cexit (Lbl nexit,[],[]) when nexit=ncatch -> handler
-  | _ ->  ccatch (ncatch, [], body, handler, dbg, kind)
+  | _ ->  ccatch (ncatch, [], body, handler, dbg, kind, false)
 
 and is_shareable_cont exp =
   match exp with

backend/comballoc.ml

@@ -113,7 +113,7 @@ let rec combine i allocstate =
       let (newbody, s') = combine body allocstate in
       let newhandlers =
         List.map
-          (fun (io, ts, handler) -> io, ts, combine_restart handler)
+          (fun (io, ts, handler, is_cold) -> io, ts, combine_restart handler, is_cold)
           handlers
       in
       let newnext = combine_restart i.next in

backend/dataflow.ml

@@ -74,19 +74,19 @@ let analyze ?(exnhandler = fun x -> x) ?(exnescape = D.bot)
         begin match rc with
         | Cmm.Nonrecursive ->
             List.iter
-              (fun (n, trap_stack, h) ->
+              (fun (n, trap_stack, h, _) ->
                  let exnh = exn_from_trap_stack exn trap_stack in
                  set_lbl n (before bx exnh h))
             handlers
         | Cmm.Recursive ->
-            List.iter (fun (n, _, _) -> add_rc_lbl n) handlers;
+            List.iter (fun (n, _, _, _) -> add_rc_lbl n) handlers;
             (* If [transfer] is monotonic and [D.t] satisfies
                the finite ascending chains condition,
                then the [while] loop below is guaranteed to terminate
                with [lbls] at the least fixed point of [before bx exnh h].
                Labels that retain their initial value at fixed point
                may be implicitly represented and absent from [lbls]. *)
-            let update changed (n, trap_stack, h) =
+            let update changed (n, trap_stack, h, _) =
               let b0 = get_lbl n in
               let exnh = exn_from_trap_stack exn trap_stack in
               let b1 = before bx exnh h in

backend/deadcode.ml

@@ -79,8 +79,8 @@ let rec deadcode i =
     let s = deadcode i.next in
     let handlers' =
       List.fold_left
-        (fun map (nfail, ts, handler) ->
-           Int.Map.add nfail (ts, deadcode handler) map)
+        (fun map (nfail, ts, handler, is_cold) ->
+           Int.Map.add nfail (ts, deadcode handler, is_cold) map)
         Int.Map.empty handlers
     in
     (* Previous passes guarantee that indexes of handlers are unique
@@ -94,8 +94,8 @@ let rec deadcode i =
         let live_exits = Int.Set.add nfail live_exits in
         match Int.Map.find_opt nfail handlers' with
         | None -> (live_exits, used_handlers)
-        | Some (ts, handler) ->
-          let used_handlers = (nfail, ts, handler) :: used_handlers in
+        | Some (ts, handler, is_cold) ->
+          let used_handlers = (nfail, ts, handler, is_cold) :: used_handlers in
           match rec_flag with
           | Cmm.Nonrecursive -> (live_exits, used_handlers)
           | Cmm.Recursive ->
@@ -106,7 +106,7 @@ let rec deadcode i =
     in
     (* Remove exits that are going out of scope. *)
     let used_handler_indexes =
-      List.fold_left (fun acc (n, _, _) -> Int.Set.add n acc)
+      List.fold_left (fun acc (n, _, _, _) -> Int.Set.add n acc)
         Int.Set.empty used_handlers
     in
     let live_exits = Int.Set.diff live_exits used_handler_indexes in
@@ -115,7 +115,7 @@ let rec deadcode i =
       match rec_flag with
       | Cmm.Recursive -> live_exits
       | Cmm.Nonrecursive ->
-        List.fold_left (fun exits (_,_,h) -> Int.Set.union h.exits exits)
+        List.fold_left (fun exits (_,_,h,_) -> Int.Set.union h.exits exits)
           live_exits
           used_handlers
     in
@@ -127,7 +127,7 @@ let rec deadcode i =
         exits;
       }
     | _ ->
-      let handlers = List.map (fun (n,ts,h) -> (n,ts,h.i)) used_handlers in
+      let handlers = List.map (fun (n,ts,h,is_cold) -> (n,ts,h.i,is_cold)) used_handlers in
       { i = { i with desc = Icatch(rec_flag, ts, handlers, body'.i);
                      next = s.i };
         regs = i.live;