new or-pat compilation + exhaustiveness used in compilation

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3273 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

18 files changed, 198 insertions, 152 deletions

diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index c9b059f72..a2e8f67ff 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -32,8 +32,8 @@ type ulambda =
   | Uletrec of (Ident.t * ulambda) list * ulambda
   | Uprim of primitive * ulambda list
   | Uswitch of ulambda * ulambda_switch
-  | Ustaticfail
-  | Ucatch of ulambda * ulambda
+  | Ustaticfail of int
+  | Ucatch of int * ulambda * ulambda
   | Utrywith of ulambda * Ident.t * ulambda
   | Uifthenelse of ulambda * ulambda * ulambda
   | Usequence of ulambda * ulambda
@@ -47,7 +47,7 @@ and ulambda_switch =
     us_cases_consts: ulambda array;
     us_index_blocks: int array;
     us_cases_blocks: ulambda array;
-    us_checked: bool }
+    us_checked: bool}
 
 (* Description of known functions *)
 
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index c9b059f72..618ad17a8 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -32,8 +32,8 @@ type ulambda =
   | Uletrec of (Ident.t * ulambda) list * ulambda
   | Uprim of primitive * ulambda list
   | Uswitch of ulambda * ulambda_switch
-  | Ustaticfail
-  | Ucatch of ulambda * ulambda
+  | Ustaticfail of int
+  | Ucatch of int * ulambda * ulambda
   | Utrywith of ulambda * Ident.t * ulambda
   | Uifthenelse of ulambda * ulambda * ulambda
   | Usequence of ulambda * ulambda
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 70795add1..5b8fc6a20 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -52,8 +52,8 @@ let occurs_var var u =
     | Uswitch(arg, s) ->
         occurs arg or occurs_array s.us_cases_consts
                    or occurs_array s.us_cases_blocks
-    | Ustaticfail -> false
-    | Ucatch(body, hdlr) -> occurs body or occurs hdlr
+    | Ustaticfail _ -> false
+    | Ucatch(_, body, hdlr) -> occurs body or occurs hdlr
     | Utrywith(body, exn, hdlr) -> occurs body or occurs hdlr
     | Uifthenelse(cond, ifso, ifnot) ->
         occurs cond or occurs ifso or occurs ifnot
@@ -131,8 +131,8 @@ let lambda_smaller lam threshold =
         lambda_size lam;
         lambda_array_size cases.us_cases_consts;
         lambda_array_size cases.us_cases_blocks
-    | Ustaticfail -> ()
-    | Ucatch(body, handler) ->
+    | Ustaticfail _ -> ()
+    | Ucatch(_, body, handler) ->
         incr size; lambda_size body; lambda_size handler
     | Utrywith(body, id, handler) ->
         size := !size + 8; lambda_size body; lambda_size handler
@@ -260,13 +260,12 @@ let substitute sb ulam =
         res
     | Uswitch(arg, sw) ->
         Uswitch(subst arg,
-                { us_index_consts = sw.us_index_consts;
+                { sw with
                   us_cases_consts = Array.map subst sw.us_cases_consts;
-                  us_index_blocks = sw.us_index_blocks;
                   us_cases_blocks = Array.map subst sw.us_cases_blocks;
-                  us_checked = sw.us_checked })
-    | Ustaticfail -> Ustaticfail
-    | Ucatch(u1, u2) -> Ucatch(subst u1, subst u2)
+                 })
+    | Ustaticfail _ as u -> u
+    | Ucatch(nfail, u1, u2) -> Ucatch(nfail, subst u1, subst u2)
     | Utrywith(u1, id, u2) -> Utrywith(subst u1, id, subst u2)
     | Uifthenelse(u1, u2, u3) ->
         begin match subst u1 with
@@ -493,22 +492,28 @@ let rec close fenv cenv = function
   | Lswitch(arg, sw) ->
       let (uarg, _) = close fenv cenv arg in
       let (const_index, const_cases) =
-        close_switch fenv cenv sw.sw_numconsts sw.sw_consts in
+        close_switch fenv cenv  sw.sw_nofail sw.sw_numconsts sw.sw_consts in
       let (block_index, block_cases) =
-        close_switch fenv cenv sw.sw_numblocks sw.sw_blocks in
+        close_switch fenv cenv  sw.sw_nofail sw.sw_numblocks sw.sw_blocks in
       (Uswitch(uarg, 
                {us_index_consts = const_index;
                 us_cases_consts = const_cases;
                 us_index_blocks = block_index;
                 us_cases_blocks = block_cases;
-                us_checked = sw.sw_checked}),
+                us_checked = sw.sw_checked && not sw.sw_nofail}),
        Value_unknown)
   | Lstaticfail ->
-      (Ustaticfail, Value_unknown)
+      (Ustaticfail 0, Value_unknown)
+  | Lstaticraise i ->
+      (Ustaticfail i, Value_unknown)
   | Lcatch(body, handler) ->
       let (ubody, _) = close fenv cenv body in
       let (uhandler, _) = close fenv cenv handler in
-      (Ucatch(ubody, uhandler), Value_unknown)
+      (Ucatch(0, ubody, uhandler), Value_unknown)
+  | Lstaticcatch(body, i, handler) ->
+      let (ubody, _) = close fenv cenv body in
+      let (uhandler, _) = close fenv cenv handler in
+      (Ucatch(i, ubody, uhandler), Value_unknown)
   | Ltrywith(body, id, handler) ->
       let (ubody, _) = close fenv cenv body in
       let (uhandler, _) = close fenv cenv handler in
@@ -649,14 +654,19 @@ and close_one_function fenv cenv id funct =
 
 (* Close a switch *)
 
-and close_switch fenv cenv num_keys cases =
+and close_switch fenv cenv nofail num_keys cases =
+  match cases, nofail with
+  | [], true ->
+      [| |], [| |] (* no need to switch here *)
+  | _,_      -> 
   let index = Array.create num_keys 0 in
   let ucases = ref []
   and num_cases = ref 0 in
-  if List.length cases < num_keys then begin
+(* if nofail holds, then static fail is replaced by a random branch *)
+  if List.length cases < num_keys && not nofail then begin
     num_cases := 1;
-    ucases := [Ustaticfail]
-  end;
+    ucases := [Ustaticfail 0]
+  end  ;
   List.iter
     (function (key, lam) ->
         let (ulam, _) = close fenv cenv lam in
diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
index 87d5525f2..c85c047a7 100644
--- a/asmcomp/cmm.ml
+++ b/asmcomp/cmm.ml
@@ -100,8 +100,8 @@ type expression =
   | Cifthenelse of expression * expression * expression
   | Cswitch of expression * int array * expression array
   | Cloop of expression
-  | Ccatch of expression * expression
-  | Cexit
+  | Ccatch of int * expression * expression
+  | Cexit of int
   | Ctrywith of expression * Ident.t * expression
 
 type fundecl =
diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
index ba3b9dfa9..6c052a4a1 100644
--- a/asmcomp/cmm.mli
+++ b/asmcomp/cmm.mli
@@ -86,8 +86,8 @@ type expression =
   | Cifthenelse of expression * expression * expression
   | Cswitch of expression * int array * expression array
   | Cloop of expression
-  | Ccatch of expression * expression
-  | Cexit
+  | Ccatch of int * expression * expression
+  | Cexit of int
   | Ctrywith of expression * Ident.t * expression
 
 type fundecl =
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 77fe5cb6f..c2c5bd36b 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -206,7 +206,7 @@ let subst_boxed_float boxed_id unboxed_id exp =
     | Cswitch(arg, index, cases) ->
         Cswitch(subst arg, index, Array.map subst cases)
     | Cloop e -> Cloop(subst e)
-    | Ccatch(e1, e2) -> Ccatch(subst e1, subst e2)
+    | Ccatch(io, e1, e2) -> Ccatch(io, subst e1, subst e2)
     | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2)
     | e -> e in
   let res = subst exp in
@@ -225,8 +225,8 @@ let rec remove_unit = function
       Cifthenelse(cond, remove_unit ifso, remove_unit ifnot)
   | Cswitch(sel, index, cases) ->
       Cswitch(sel, index, Array.map remove_unit cases)
-  | Ccatch(body, handler) ->
-      Ccatch(remove_unit body, remove_unit handler)
+  | Ccatch(io, body, handler) ->
+      Ccatch(io, remove_unit body, remove_unit handler)
   | Ctrywith(body, exn, handler) ->
       Ctrywith(remove_unit body, exn, remove_unit handler)
   | Clet(id, c1, c2) ->
@@ -235,7 +235,7 @@ let rec remove_unit = function
       Cop(Capply typ_void, args)
   | Cop(Cextcall(proc, mty, alloc), args) ->
       Cop(Cextcall(proc, typ_void, alloc), args)
-  | Cexit -> Cexit
+  | Cexit _ as c -> c
   | Ctuple [] as c -> c
   | c -> Csequence(c, Ctuple [])
 
@@ -766,7 +766,7 @@ let rec transl = function
             Cifthenelse(
               Cop(Ccmpa Cge,
                   [idx; Cconst_pointer(Array.length s.us_index_consts)]),
-              Cexit,
+              Cexit 0,
               transl_switch idx s.us_index_consts s.us_cases_consts))
         else
           transl_switch (untag_int (transl arg))
@@ -780,42 +780,45 @@ let rec transl = function
             Cop(Cand, [arg; Cconst_int 1]),
             transl_switch (untag_int arg) s.us_index_consts s.us_cases_consts,
             transl_switch (get_tag arg) s.us_index_blocks s.us_cases_blocks))
-  | Ustaticfail ->
-      Cexit
-  | Ucatch(body, handler) ->
-      Ccatch(transl body, transl handler)
+  | Ustaticfail nfail -> Cexit nfail
+  | Ucatch(nfail, body, handler) ->
+      Ccatch(nfail, transl body, transl handler)
   | Utrywith(body, exn, handler) ->
       Ctrywith(transl body, exn, transl handler)
   | Uifthenelse(Uprim(Pnot, [arg]), ifso, ifnot) ->
       transl (Uifthenelse(arg, ifnot, ifso))
-  | Uifthenelse(cond, ifso, Ustaticfail) ->
-      exit_if_false cond (transl ifso)
-  | Uifthenelse(cond, Ustaticfail, ifnot) ->
-      exit_if_true cond (transl ifnot)
+  | Uifthenelse(cond, ifso, Ustaticfail io) ->
+      exit_if_false cond (transl ifso) io
+  | Uifthenelse(cond, Ustaticfail io, ifnot) ->
+      exit_if_true cond io (transl ifnot)
   | Uifthenelse(Uprim(Psequand, _) as cond, ifso, ifnot) ->
-      Ccatch(exit_if_false cond (transl ifso), transl ifnot)
+      Ccatch(0, exit_if_false cond (transl ifso) 0, transl ifnot)
   | Uifthenelse(Uprim(Psequor, _) as cond, ifso, ifnot) ->
-      Ccatch(exit_if_true cond (transl ifnot), transl ifso)
+      Ccatch(0, exit_if_true cond 0 (transl ifnot), transl ifso)
   | Uifthenelse(cond, ifso, ifnot) ->
       Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot)
   | Usequence(exp1, exp2) ->
       Csequence(remove_unit(transl exp1), transl exp2)
   | Uwhile(cond, body) ->
-      return_unit(Ccatch(Cloop(exit_if_false cond (remove_unit(transl body))),
-                         Ctuple []))
+      return_unit
+        (Ccatch
+           (0,
+            Cloop(exit_if_false cond (remove_unit(transl body)) 0),
+            Ctuple []))
   | Ufor(id, low, high, dir, body) ->
       let tst = match dir with Upto -> Cgt   | Downto -> Clt in
       let inc = match dir with Upto -> Caddi | Downto -> Csubi in
       return_unit
         (Clet(id, transl low,
           bind_nonvar "bound" (transl high) (fun high ->
-            Ccatch(
-              Cifthenelse(Cop(Ccmpi tst, [Cvar id; high]), Cexit,
+            Ccatch
+              (0,
+               Cifthenelse(Cop(Ccmpi tst, [Cvar id; high]), Cexit 0,
                 Cloop(
                   Csequence(remove_unit(transl body),
                     Csequence(Cassign(id, Cop(inc, [Cvar id; Cconst_int 2])),
                       Cifthenelse(Cop(Ccmpi tst, [Cvar id; high]),
-                                  Cexit, Ctuple []))))),
+                                  Cexit 0, Ctuple []))))),
               Ctuple []))))
   | Uassign(id, exp) ->
       return_unit(Cassign(id, transl exp))
@@ -1143,31 +1146,31 @@ and transl_unbox_int bi = function
       Cconst_int i
   | exp -> unbox_int bi (transl exp)
 
-and exit_if_true cond otherwise =
+and exit_if_true cond nfail otherwise =
   match cond with
     Uprim(Psequor, [arg1; arg2]) ->
-      exit_if_true arg1 (exit_if_true arg2 otherwise)
+      exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise)
   | Uprim(Psequand, [arg1; arg2]) ->
-      Csequence(Ccatch(exit_if_true arg1 (Ctuple []),
-                       exit_if_true arg2 (Ctuple [])),
+      Csequence(Ccatch(nfail, exit_if_true arg1 nfail (Ctuple []),
+                       exit_if_true arg2 nfail (Ctuple [])),
                 otherwise)
   | Uprim(Pnot, [arg]) ->
-      exit_if_false arg otherwise
+      exit_if_false arg otherwise nfail
   | _ ->
-      Cifthenelse(test_bool(transl cond), Cexit, otherwise)
+      Cifthenelse(test_bool(transl cond), Cexit nfail, otherwise)
 
-and exit_if_false cond otherwise =
+and exit_if_false cond otherwise nfail =
   match cond with
     Uprim(Psequand, [arg1; arg2]) ->
-      exit_if_false arg1 (exit_if_false arg2 otherwise)
+      exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail
   | Uprim(Psequor, [arg1; arg2]) ->
-      Csequence(Ccatch(exit_if_false arg1 (Ctuple []),
-                       exit_if_false arg2 (Ctuple [])),
+      Csequence(Ccatch(0, exit_if_false arg1 (Ctuple []) 0,
+                       exit_if_false arg2 (Ctuple []) 0),
                 otherwise)
   | Uprim(Pnot, [arg]) ->
-      exit_if_true arg otherwise
+      exit_if_true arg nfail otherwise
   | _ ->
-      Cifthenelse(test_bool(transl cond), otherwise, Cexit)
+      Cifthenelse(test_bool(transl cond), otherwise, Cexit nfail)
 
 and transl_switch arg index cases =
   match Array.length index with
@@ -1175,24 +1178,24 @@ and transl_switch arg index cases =
   | 2 -> Cifthenelse(arg, transl cases.(index.(1)), transl cases.(index.(0)))
   | _ ->
       (* Determine whether all actions minus one or two are equal to
-         Ustaticfail *)
+         Ustaticfail 0 *)
       let num_fail = ref 0 in
       let key1 = ref (-1) in
       let key2 = ref (-1) in
       for i = 0 to Array.length index - 1 do
-        if cases.(index.(i)) = Ustaticfail then incr num_fail
+        if cases.(index.(i)) = Ustaticfail 0 then incr num_fail
         else if !key1 < 0 then key1 := i
         else if !key2 < 0 then key2 := i
       done;
       match Array.length index - !num_fail with
-        0 -> Csequence(arg, Cexit)
+        0 -> Csequence(arg, Cexit 0)
       | 1 -> Cifthenelse(Cop(Ccmpi Ceq, [arg; Cconst_int !key1]),
-                         transl cases.(index.(!key1)), Cexit)
+                         transl cases.(index.(!key1)), Cexit 0)
       | 2 -> bind "test" arg (fun a ->
                Cifthenelse(Cop(Ccmpi Ceq, [a; Cconst_int !key1]),
                            transl cases.(index.(!key1)),
                            Cifthenelse(Cop(Ccmpi Ceq, [a; Cconst_int !key2]),
-                                       transl cases.(index.(!key2)), Cexit)))
+                                       transl cases.(index.(!key2)), Cexit 0)))
       | _ -> Cswitch(arg, index, Array.map transl cases)
 
 and transl_letrec bindings cont =
diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml
index 16f7b9869..adc4123aa 100644
--- a/asmcomp/comballoc.ml
+++ b/asmcomp/comballoc.ml
@@ -29,7 +29,7 @@ let allocated_size = function
 
 let rec combine i allocstate =
   match i.desc with
-    Iend | Ireturn | Iexit | Iraise ->
+    Iend | Ireturn | Iexit _ | Iraise ->
       (i, allocated_size allocstate)
   | Iop(Ialloc sz) ->
       begin match allocstate with
@@ -71,11 +71,11 @@ let rec combine i allocstate =
       let newbody = combine_restart body in
       (instr_cons (Iloop(newbody)) i.arg i.res i.next,
        allocated_size allocstate)
-  | Icatch(body, handler) ->
+  | Icatch(io, body, handler) ->
       let (newbody, sz) = combine body allocstate in
       let newhandler = combine_restart handler in
       let newnext = combine_restart i.next in
-      (instr_cons (Icatch(newbody, newhandler)) i.arg i.res newnext, sz)
+      (instr_cons (Icatch(io, newbody, newhandler)) i.arg i.res newnext, sz)
   | Itrywith(body, handler) ->
       let (newbody, sz) = combine body allocstate in
       let newhandler = combine_restart handler in
diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml
index e6140c3f2..1bc14de74 100644
--- a/asmcomp/interf.ml
+++ b/asmcomp/interf.ml
@@ -102,9 +102,9 @@ let build_graph fundecl =
         interf i.next
     | Iloop body ->
         interf body; interf i.next
-    | Icatch(body, handler) ->
+    | Icatch(_, body, handler) ->
         interf body; interf handler; interf i.next
-    | Iexit ->
+    | Iexit _ ->
         ()
     | Itrywith(body, handler) ->
         add_interf_set Proc.destroyed_at_raise handler.live;    
@@ -175,9 +175,9 @@ let build_graph fundecl =
         (* Avoid overflow of weight and spill_cost *)
         prefer (if weight < 1000 then 8 * weight else weight) body;
         prefer weight i.next
-    | Icatch(body, handler) ->
+    | Icatch(_, body, handler) ->
         prefer weight body; prefer weight handler; prefer weight i.next
-    | Iexit ->
+    | Iexit _ ->
         ()
     | Itrywith(body, handler) ->
         prefer weight body; prefer weight handler; prefer weight i.next
diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml
index 7a4704f38..b98cb5ef2 100644
--- a/asmcomp/linearize.ml
+++ b/asmcomp/linearize.ml
@@ -124,9 +124,15 @@ let add_branch lbl n =
     Llabel lbl1 when lbl1 = lbl -> n1
   | _ -> cons_instr (Lbranch lbl) n1
 
-(* Current label for exit handler *)
+(* Current labels for exit handler *)
 
-let exit_label = ref None
+let exit_label = ref []
+
+let find_exit_label k =
+  try
+    List.assoc k !exit_label
+  with
+  | Not_found -> Misc.fatal_error "Linearize.find_exit_label"
 
 (* Linearize an instruction [i]: add it in front of the continuation [n] *)
 
@@ -152,16 +158,14 @@ let rec linear i n =
           copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1)
       | _, Iend, Lbranch lbl ->
           copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1)
-      | Iexit, _, _ ->
+      | Iexit nfail, _, _ ->
           let n2 = linear ifnot n1 in
-          begin match !exit_label with None -> n2
-          | Some lbl -> copy_instr (Lcondbranch(test, lbl)) i n2
-          end
-      | _,  Iexit, _ ->
+          let lbl = find_exit_label nfail in
+          copy_instr (Lcondbranch(test, lbl)) i n2
+      | _,  Iexit nfail, _ ->
           let n2 = linear ifso n1 in
-          begin match !exit_label with None -> n2
-          | Some lbl -> copy_instr (Lcondbranch(invert_test test, lbl)) i n2
-          end
+          let lbl = find_exit_label nfail in
+          copy_instr (Lcondbranch(invert_test test, lbl)) i n2
       | Iend, _, _ ->
           let (lbl_end, n2) = get_label n1 in
           copy_instr (Lcondbranch(test, lbl_end)) i (linear ifnot n2)
@@ -203,19 +207,17 @@ let rec linear i n =
       let n1 = linear i.Mach.next n in
       let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in
       cons_instr (Llabel lbl_head) n2
-  | Icatch(body, handler) ->
+  | Icatch(io, body, handler) ->
       let (lbl_end, n1) = get_label(linear i.Mach.next n) in
       let (lbl_handler, n2) = get_label(linear handler n1) in
-      let saved_exit_label = !exit_label in
-      exit_label := Some lbl_handler;
+      exit_label := (io, lbl_handler) :: !exit_label ;
       let n3 = linear body (add_branch lbl_end n2) in
-      exit_label := saved_exit_label;
+      exit_label := List.tl !exit_label;
       n3
-  | Iexit ->
+  | Iexit nfail ->
       let n1 = linear i.Mach.next n in
-      begin match !exit_label with None -> n1
-      | Some lbl -> add_branch lbl n1
-      end
+      let lbl = find_exit_label nfail in
+      add_branch lbl n1
   | Itrywith(body, handler) ->
       let (lbl_join, n1) = get_label (linear i.Mach.next n) in
       let (lbl_body, n2) =
diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml
index fcbb20839..c9c90c8b5 100644
--- a/asmcomp/liveness.ml
+++ b/asmcomp/liveness.ml
@@ -17,7 +17,13 @@
 
 open Mach
 
-let live_at_exit = ref Reg.Set.empty
+let live_at_exit = ref []
+let find_live_at_exit k =
+  try
+    List.assoc k !live_at_exit
+  with
+  | Not_found -> Misc.fatal_error "Spill.find_live_at_exit"
+
 let live_at_break = ref Reg.Set.empty
 let live_at_raise = ref Reg.Set.empty
 
@@ -62,18 +68,20 @@ let rec live i finally =
       end;
       i.live <- !at_top;
       !at_top
-  | Icatch(body, handler) ->
+  | Icatch(nfail, body, handler) ->
       let at_join = live i.next finally in
       let before_handler = live handler at_join in
-      let saved_live_at_exit = !live_at_exit in
-      live_at_exit := before_handler;
-      let before_body = live body at_join in
-      live_at_exit := saved_live_at_exit;
+      let before_body =
+          live_at_exit := (nfail,before_handler) :: !live_at_exit ;
+          let before_body = live body at_join in
+          live_at_exit := List.tl !live_at_exit ;
+          before_body in
       i.live <- before_body;
       before_body
-  | Iexit ->
-      i.live <- !live_at_exit;          (* These regs are live across *)
-      !live_at_exit
+  | Iexit nfail ->
+      let this_live = find_live_at_exit nfail in
+      i.live <- this_live ;
+      this_live
   | Itrywith(body, handler) ->
       let at_join = live i.next finally in
       let before_handler = live handler at_join in
diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index db19eae69..6417b5c40 100644
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -69,8 +69,8 @@ and instruction_desc =
   | Iifthenelse of test * instruction * instruction
   | Iswitch of int array * instruction array
   | Iloop of instruction
-  | Icatch of instruction * instruction
-  | Iexit
+  | Icatch of int * instruction * instruction
+  | Iexit of int
   | Itrywith of instruction * instruction
   | Iraise
 
@@ -117,9 +117,9 @@ let rec instr_iter f i =
           instr_iter f i.next
       | Iloop(body) ->
           instr_iter f body; instr_iter f i.next
-      | Icatch(body, handler) ->
+      | Icatch(_, body, handler) ->
           instr_iter f body; instr_iter f handler; instr_iter f i.next
-      | Iexit -> ()
+      | Iexit _ -> ()
       | Itrywith(body, handler) ->
           instr_iter f body; instr_iter f handler; instr_iter f i.next
       | Iraise -> ()
diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index 9f35c4e7d..ec10ffb81 100644
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -69,8 +69,8 @@ and instruction_desc =
   | Iifthenelse of test * instruction * instruction
   | Iswitch of int array * instruction array
   | Iloop of instruction
-  | Icatch of instruction * instruction
-  | Iexit
+  | Icatch of int * instruction * instruction
+  | Iexit of int 
   | Itrywith of instruction * instruction
   | Iraise
 
diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
index 3e51b0401..1367b4b36 100644
--- a/asmcomp/printcmm.ml
+++ b/asmcomp/printcmm.ml
@@ -144,10 +144,12 @@ let rec expr ppf = function
       fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases 
   | Cloop e ->
       fprintf ppf "@[<2>(loop@ %a)@]" sequence e
-  | Ccatch(e1, e2) ->
-      fprintf ppf "@[<2>(catch@ %a@;<1 -2>with@ %a)@]" sequence e1 sequence e2
-  | Cexit ->
-      fprintf ppf "exit"
+  | Ccatch(i, e1, e2) ->
+      fprintf ppf
+        "@[<2>(catch@ %a@;<1 -2>with(%d)@ %a)@]"
+        sequence e1 i sequence e2
+  | Cexit i ->
+      fprintf ppf "exit(%d)" i
   | Ctrywith(e1, id, e2) ->
       fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]"
              sequence e1 Ident.print id sequence e2
diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index 54728ee2d..17cf675b9 100644
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -42,7 +42,7 @@ let regs ppf v =
   | 0 -> ()
   | 1 -> reg ppf v.(0)
   | n -> reg ppf v.(0);
-         for i = 1 to n-1 do fprintf ppf " %a" reg v.(i) done
+         for i = 1 to n-1 do fprintf ppf "@ %a" reg v.(i) done
 
 let regset ppf s =
   let first = ref true in
@@ -170,11 +170,12 @@ let rec instr ppf i =
       fprintf ppf "@,endswitch"
   | Iloop(body) ->
       fprintf ppf "@[<v 2>loop@,%a@;<0 -2>endloop@]" instr body
-  | Icatch(body, handler) ->
-      fprintf ppf "@[<v 2>catch@,%a@;<0 -2>with@,%a@;<0 -2>endcatch@]"
-             instr body instr handler
-  | Iexit ->
-      fprintf ppf "exit"
+  | Icatch(i, body, handler) ->
+      fprintf
+        ppf "@[<v 2>catch@,%a@;<0 -2>with(%d)@,%a@;<0 -2>endcatch@]"
+        instr body i instr handler
+  | Iexit i ->
+      fprintf ppf "exit(%d)" i
   | Itrywith(body, handler) ->
       fprintf ppf "@[<v 2>try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]"
              instr body instr handler
diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml
index 1baf47d29..f4b3cf7ff 100644
--- a/asmcomp/reloadgen.ml
+++ b/asmcomp/reloadgen.ml
@@ -120,11 +120,12 @@ method private reload i =
           (self#reload i.next))
   | Iloop body ->
       instr_cons (Iloop(self#reload body)) [||] [||] (self#reload i.next)
-  | Icatch(body, handler) ->
-      instr_cons (Icatch(self#reload body, self#reload handler)) [||] [||]
+  | Icatch(nfail, body, handler) ->
+      instr_cons
+        (Icatch(nfail, self#reload body, self#reload handler)) [||] [||]
         (self#reload i.next)
-  | Iexit ->
-      instr_cons Iexit [||] [||] dummy_instr
+  | Iexit i ->
+      instr_cons (Iexit i) [||] [||] dummy_instr
   | Itrywith(body, handler) ->
       instr_cons (Itrywith(self#reload body, self#reload handler)) [||] [||]
         (self#reload i.next)
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index d895876e5..88793aad1 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -477,14 +477,14 @@ method emit_expr env exp =
       let (rarg, sbody) = self#emit_sequence env ebody in
       self#insert (Iloop(sbody#extract)) [||] [||];
       [||]
-  | Ccatch(e1, e2) ->
+  | Ccatch(nfail, e1, e2) ->
       let (r1, s1) = self#emit_sequence env e1 in
       let (r2, s2) = self#emit_sequence env e2 in
       let r = join r1 s1 r2 s2 in
-      self#insert (Icatch(s1#extract, s2#extract)) [||] [||];
+      self#insert (Icatch(nfail, s1#extract, s2#extract)) [||] [||];
       r
-  | Cexit ->
-      self#insert Iexit [||] [||];
+  | Cexit nfail ->
+      self#insert (Iexit nfail) [||] [||];
       [||]
   | Ctrywith(e1, v, e2) ->
       Proc.contains_calls := true;
@@ -662,12 +662,12 @@ method emit_tail env exp =
       self#insert
         (Iswitch(index, Array.map (self#emit_tail_sequence env) ecases))
         rsel [||]
-  | Ccatch(e1, e2) ->
-      self#insert (Icatch(self#emit_tail_sequence env e1,
+  | Ccatch(io, e1, e2) ->
+      self#insert (Icatch(io, self#emit_tail_sequence env e1,
                           self#emit_tail_sequence env e2))
                   [||] [||]
-  | Cexit ->
-      self#insert Iexit [||] [||]
+  | Cexit io ->
+      self#insert (Iexit io) [||] [||]
   | Ctrywith(e1, v, e2) ->
       Proc.contains_calls := true;
       let (r1, s1) = self#emit_sequence env e1 in
diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml
index 972de7d18..24d957b9c 100644
--- a/asmcomp/spill.ml
+++ b/asmcomp/spill.ml
@@ -123,7 +123,14 @@ let add_reloads regset i =
     (fun r i -> instr_cons (Iop Ireload) [|spill_reg r|] [|r|] i)
     regset i
 
-let reload_at_exit = ref Reg.Set.empty
+let reload_at_exit = ref []
+
+let find_reload_at_exit k =
+  try
+    List.assoc k !reload_at_exit
+  with
+  | Not_found -> Misc.fatal_error "Spill.find_reload_at_exit"
+        
 let reload_at_break = ref Reg.Set.empty
 
 let rec reload i before =
@@ -211,19 +218,20 @@ let rec reload i before =
       let (new_next, finally) = reload i.next Reg.Set.empty in
       (instr_cons (Iloop(!final_body)) i.arg i.res new_next,
        finally)
-  | Icatch(body, handler) ->
-      let saved_reload_at_exit = !reload_at_exit in
-      reload_at_exit := Reg.Set.empty;
+  | Icatch(nfail, body, handler) ->
+      let new_set = ref Reg.Set.empty in
+      reload_at_exit := (nfail, new_set) :: !reload_at_exit ;
       let (new_body, after_body) = reload body before in
-      let at_exit = !reload_at_exit in
-      reload_at_exit := saved_reload_at_exit;
+      let at_exit = !new_set in
+      reload_at_exit := List.tl !reload_at_exit ;
       let (new_handler, after_handler) = reload handler at_exit in
       let (new_next, finally) =
         reload i.next (Reg.Set.union after_body after_handler) in
-      (instr_cons (Icatch(new_body, new_handler)) i.arg i.res new_next,
+      (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next,
        finally)
-  | Iexit ->
-      reload_at_exit := Reg.Set.union !reload_at_exit before;
+  | Iexit nfail ->
+      let set = find_reload_at_exit nfail in
+      set := Reg.Set.union !set before;
       (i, Reg.Set.empty)
   | Itrywith(body, handler) ->
       let (new_body, after_body) = reload body before in
@@ -245,7 +253,13 @@ let rec reload i before =
    This strategy is turned off in loops, as it may prevent a spill from
    being lifted up all the way out of the loop. *)
 
-let spill_at_exit = ref Reg.Set.empty
+let spill_at_exit = ref []
+let find_spill_at_exit k =
+  try
+    List.assoc k !spill_at_exit
+  with
+  | Not_found -> Misc.fatal_error "Spill.find_spill_at_exit"
+
 let spill_at_raise = ref Reg.Set.empty
 let inside_loop = ref false
 
@@ -332,17 +346,16 @@ let rec spill i finally =
       inside_loop := saved_inside_loop;
       (instr_cons (Iloop(!final_body)) i.arg i.res new_next,
        !at_head)
-  | Icatch(body, handler) ->
+  | Icatch(nfail, body, handler) ->
       let (new_next, at_join) = spill i.next finally in
       let (new_handler, at_exit) = spill handler at_join in
-      let saved_spill_at_exit = !spill_at_exit in
-      spill_at_exit := at_exit;
+      spill_at_exit := (nfail, at_exit) :: !spill_at_exit ;
       let (new_body, before) = spill body at_join in
-      spill_at_exit := saved_spill_at_exit;
-      (instr_cons (Icatch(new_body, new_handler)) i.arg i.res new_next,
+      spill_at_exit := List.tl !spill_at_exit;
+      (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next,
        before)
-  | Iexit ->
-      (i, !spill_at_exit)
+  | Iexit nfail ->
+      (i, find_spill_at_exit nfail)
   | Itrywith(body, handler) ->
       let (new_next, at_join) = spill i.next finally in
       let (new_handler, before_handler) = spill handler at_join in
diff --git a/asmcomp/split.ml b/asmcomp/split.ml
index 51f19238a..06a09ed04 100644
--- a/asmcomp/split.ml
+++ b/asmcomp/split.ml
@@ -113,7 +113,12 @@ let merge_subst_array subv instr =
 
 (* First pass: rename registers at reload points *)
 
-let exit_subst = ref (None: subst option)
+let exit_subst = ref []
+
+let find_exit_subst k =
+  try
+    List.assoc k !exit_subst with
+  | Not_found -> Misc.fatal_error "Split.find_exit_subst"
 
 let rec rename i sub =
   match i.desc with
@@ -159,19 +164,20 @@ let rec rename i sub =
       let (new_next, sub_next) = rename i.next (merge_substs sub sub_body i) in
       (instr_cons (Iloop(new_body)) [||] [||] new_next,
        sub_next)
-  | Icatch(body, handler) ->
-      let saved_exit_subst = !exit_subst in
-      exit_subst := None;
+  | Icatch(nfail, body, handler) ->
+      let new_subst = ref None in
+      exit_subst := (nfail, new_subst) :: !exit_subst ;
       let (new_body, sub_body) = rename body sub in
-      let sub_entry_handler = !exit_subst in
-      exit_subst := saved_exit_subst;
+      let sub_entry_handler = !new_subst in
+      exit_subst := List.tl !exit_subst;
       let (new_handler, sub_handler) = rename handler sub_entry_handler in
       let (new_next, sub_next) =
         rename i.next (merge_substs sub_body sub_handler i.next) in
-      (instr_cons (Icatch(new_body, new_handler)) [||] [||] new_next,
+      (instr_cons (Icatch(nfail, new_body, new_handler)) [||] [||] new_next,
        sub_next)
-  | Iexit ->
-      exit_subst := merge_substs !exit_subst sub i;
+  | Iexit nfail ->
+      let r = find_exit_subst nfail in
+      r := merge_substs !r sub i;
       (i, None)
   | Itrywith(body, handler) ->
       let (new_body, sub_body) = rename body sub in