Merge pull request #9647 from trefis/rematch-matching-handler-fun

pattern-matching refactoring: first-order representation for failure handlers

Changes

@@ -193,7 +193,8 @@ Working version
 - #9216: add Lambda.duplicate which refreshes bound identifiers
   (Gabriel Scherer, review by Pierre Chambart and Vincent Laviron)
 
-- #9493, #9520, #9563, #9599, #9608: refactor the pattern-matching compiler
+- #9493, #9520, #9563, #9599, #9608, #9647: refactor
+  the pattern-matching compiler
   (Thomas Refis and Gabriel Scherer, review by Florian Angeletti)
 
 - #9604: refactoring of the ocamltest codebase.

lambda/matching.ml

@@ -3325,13 +3325,47 @@ let check_partial pat_act_list =
 
 (* have toplevel handler when appropriate *)
 
-let check_total total lambda i handler_fun =
+type failer_kind =
+  | Raise_match_failure
+  | Reraise_noloc of lambda
+
+let failure_handler ~scopes loc ~failer () =
+  match failer with
+  | Reraise_noloc exn_lam ->
+    Lprim (Praise Raise_reraise, [ exn_lam ], Scoped_location.Loc_unknown)
+  | Raise_match_failure ->
+    let sloc = Scoped_location.of_location ~scopes loc in
+    let slot =
+      transl_extension_path sloc
+        Env.initial_safe_string Predef.path_match_failure
+    in
+    let fname, line, char =
+      Location.get_pos_info loc.Location.loc_start in
+    Lprim
+      ( Praise Raise_regular,
+        [ Lprim
+            ( Pmakeblock (0, Immutable, None),
+              [ slot;
+                Lconst
+                  (Const_block
+                     ( 0,
+                       [ Const_base (Const_string (fname, loc, None));
+                         Const_base (Const_int line);
+                         Const_base (Const_int char)
+                       ] ))
+              ],
+              sloc )
+        ],
+        sloc )
+
+let check_total ~scopes loc ~failer total lambda i =
   if Jumps.is_empty total then
     lambda
   else
-    Lstaticcatch (lambda, (i, []), handler_fun ())
+    Lstaticcatch (lambda, (i, []),
+                  failure_handler ~scopes loc ~failer ())
 
-let compile_matching ~scopes repr handler_fun arg pat_act_list partial =
+let compile_matching ~scopes loc ~failer repr arg pat_act_list partial =
   let partial = check_partial pat_act_list partial in
   match partial with
   | Partial -> (
@@ -3346,7 +3380,7 @@ let compile_matching ~scopes repr handler_fun arg pat_act_list partial =
       try
         let lambda, total =
           compile_match ~scopes repr partial (Context.start 1) pm in
-        check_total total lambda raise_num handler_fun
+        check_total ~scopes loc ~failer total lambda raise_num
       with Unused -> assert false
       (* ; handler_fun() *)
     )
@@ -3362,43 +3396,25 @@ let compile_matching ~scopes repr handler_fun arg pat_act_list partial =
       assert (Jumps.is_empty total);
       lambda
 
-let partial_function ~scopes loc () =
-  let sloc = Scoped_location.of_location ~scopes loc in
-  let slot =
-    transl_extension_path sloc Env.initial_safe_string Predef.path_match_failure
-  in
-  let fname, line, char =
-    Location.get_pos_info loc.Location.loc_start in
-  Lprim
-    ( Praise Raise_regular,
-      [ Lprim
-          ( Pmakeblock (0, Immutable, None),
-            [ slot;
-              Lconst
-                (Const_block
-                   ( 0,
-                     [ Const_base (Const_string (fname, loc, None));
-                       Const_base (Const_int line);
-                       Const_base (Const_int char)
-                     ] ))
-            ],
-            sloc )
-      ],
-      sloc )
-
 let for_function ~scopes loc repr param pat_act_list partial =
-  let f () = partial_function ~scopes loc () in
-  compile_matching ~scopes repr f param pat_act_list partial
+  compile_matching ~scopes loc ~failer:Raise_match_failure
+    repr param pat_act_list partial
 
 (* In the following two cases, exhaustiveness info is not available! *)
-let for_trywith ~scopes param pat_act_list =
-  compile_matching ~scopes None
-    (fun () -> Lprim (Praise Raise_reraise, [ param ], Loc_unknown))
-    param pat_act_list Partial
+let for_trywith ~scopes loc param pat_act_list =
+  (* Note: the failure action of [for_trywith] corresponds
+     to an exception that is not matched by a try..with handler,
+     and is thus reraised for the next handler in the stack.
+
+     It is important to *not* include location information in
+     the reraise (hence the [_noloc]) to avoid seeing this
+     silent reraise in exception backtraces. *)
+  compile_matching ~scopes loc ~failer:(Reraise_noloc param)
+    None param pat_act_list Partial
 
 let simple_for_let ~scopes loc param pat body =
-  compile_matching ~scopes None (partial_function ~scopes loc)
-    param [ (pat, body) ] Partial
+  compile_matching ~scopes loc ~failer:Raise_match_failure
+    None param [ (pat, body) ] Partial
 
 (* Optimize binding of immediate tuples
 
@@ -3576,8 +3592,10 @@ let for_tupled_function ~scopes loc paraml pats_act_list partial =
       compile_match ~scopes None partial
         (Context.start (List.length paraml)) pm
     in
-    check_total total lambda raise_num (partial_function ~scopes loc)
-  with Unused -> partial_function ~scopes loc ()
+    check_total ~scopes loc ~failer:Raise_match_failure
+      total lambda raise_num
+  with Unused ->
+    failure_handler ~scopes loc ~failer:Raise_match_failure ()
 
 let flatten_pattern size p =
   match p.pat_desc with
@@ -3684,7 +3702,8 @@ let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
           compile_match ~scopes None partial (Context.start 1) pm1 in
         begin match partial with
         | Partial ->
-            check_total total lambda raise_num (partial_function ~scopes loc)
+            check_total ~scopes loc ~failer:Raise_match_failure
+              total lambda raise_num
         | Total ->
             assert (Jumps.is_empty total);
             lambda
@@ -3704,7 +3723,8 @@ let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
         List.fold_right2 (bind Strict) idl paraml
           ( match partial with
           | Partial ->
-              check_total total lam raise_num (partial_function ~scopes loc)
+              check_total ~scopes loc ~failer:Raise_match_failure
+                total lam raise_num
           | Total ->
               assert (Jumps.is_empty total);
               lam

lambda/matching.mli

@@ -25,7 +25,7 @@ val for_function:
         int ref option -> lambda -> (pattern * lambda) list -> partial ->
         lambda
 val for_trywith:
-        scopes:scopes ->
+        scopes:scopes -> Location.t ->
         lambda -> (pattern * lambda) list ->
         lambda
 val for_let:

lambda/translcore.ml

@@ -292,7 +292,7 @@ and transl_exp0 ~scopes e =
   | Texp_try(body, pat_expr_list) ->
       let id = Typecore.name_cases "exn" pat_expr_list in
       Ltrywith(transl_exp ~scopes body, id,
-               Matching.for_trywith ~scopes (Lvar id)
+               Matching.for_trywith ~scopes e.exp_loc (Lvar id)
                  (transl_cases_try ~scopes pat_expr_list))
   | Texp_tuple el ->
       let ll, shape = transl_list_with_shape ~scopes el in
@@ -1035,7 +1035,7 @@ and transl_match ~scopes e arg pat_expr_list partial =
     let static_exception_id = next_raise_count () in
     Lstaticcatch
       (Ltrywith (Lstaticraise (static_exception_id, body), id,
-                 Matching.for_trywith ~scopes (Lvar id) exn_cases),
+                 Matching.for_trywith ~scopes e.exp_loc (Lvar id) exn_cases),
        (static_exception_id, val_ids),
        handler)
   in