Keep a case's guard as data until its fallthrough is known

Matching encoded a guard as a term and recovered it afterwards by shape:
translcore emitted [if cond then body else Lstaticraise (0, [])], and
is_guarded / patch_guarded recognised that shape to substitute the real
fallthrough. Exit zero was a sentinel, not an exit.

Normalization cannot know a shape is a message. Fold the condition of
[x if 1 > 2] and if_ correctly returns the else branch, so the action becomes
a bare raise to an exit that has no catch, is_guarded stops recognising it,
nothing patches it, and the raise reaches codegen alone. That is what broke
the analysis corpus when mk_builtin started folding.

Carry the guard as data instead. A case's right-hand side is now

  type action = {
    binds: (let_kind * Ident.t * Lambda.t) list;
    guard: Lambda.t option;
    body: Lambda.t;
  }

lowered at the single point where the fallthrough exists - the row that
matches in compile_match. The bindings are there because simplification
brings pattern variables into scope with lets that must cover the guard as
well as the body; keeping them as data preserves that without a term to
recurse through. staticfail, is_guarded and patch_guarded are deleted, and
exit zero is no longer magic.

Comparing actions needs a stand-in for the fallthrough, and it must be a
fresh variable rather than a constant: with unit, [when g => e] and
[_ => if g then e else ()] produce the same key, and merging them loses one
evaluation of g. The variable is created per comparison, so its freshness
does not depend on ident stamps surviving Ident.reinit between units.

guard_action_test pins both: a guard that folds to false is not a missing
guard, and two actions that differ only in where the condition sits are not
the same action. Each fails on the unfixed compiler.

Generated JavaScript is unchanged.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H

Author: cristianoc

compiler/ml/lambda.ml

@@ -1457,19 +1457,6 @@ let next_negative_raise_count () =
   !negative_raise_count
 
 (* Anticipated staticraise, for guards *)
-let staticfail = Lstaticraise (0, [])
-
-let rec is_guarded = function
-  | Lifthenelse (_cond, _body, Lstaticraise (0, [])) -> true
-  | Llet (_str, _id, _lam, body) -> is_guarded body
-  | _ -> false
-
-let rec patch_guarded patch = function
-  | Lifthenelse (cond, body, Lstaticraise (0, [])) ->
-    Lifthenelse (cond, body, patch)
-  | Llet (str, id, lam, body) -> Llet (str, id, lam, patch_guarded patch body)
-  | _ -> assert false
-
 (* Translate an access path *)
 
 let rec transl_normal_path = function

compiler/ml/lambda.mli

@@ -599,9 +599,3 @@ val next_negative_raise_count : unit -> int
    exception x -> ...'.  This disabled some simplifications
    performed by the Simplif module that assume that static raises
    are in tail position in their handler. *)
-
-val staticfail : t (* Anticipated static failure *)
-
-(* Check anticipated failure, substitute its final value *)
-val is_guarded : t -> bool
-val patch_guarded : t -> t -> t

compiler/ml/matching.ml

@@ -345,8 +345,56 @@ let jumps_map f env = List.map (fun (i, pss) -> (i, f pss)) env
 
 (* Pattern matching before any compilation *)
 
+(* A case's right-hand side, kept as data until the fallthrough it may need
+   is known. Encoding the guard as a term and recognizing it by shape
+   afterwards would let normalization erase it: a guard that folds to false
+   is not a missing guard. Simplification brings pattern variables into
+   scope with lets, which must cover the guard as well as the body, so those
+   accumulate here too, outermost first. *)
+type action = {
+  binds: (let_kind * Ident.t * Lambda.t) list;
+  guard: Lambda.t option;
+  body: Lambda.t;
+}
+
+let unguarded body = {binds = []; guard = None; body}
+let guarded ~guard body = {binds = []; guard = Some guard; body}
+
+(* Bring [id = e] into scope over the whole right-hand side. Like
+   [Lambda.bind], an alias of a variable to itself is dropped. *)
+let bind_action kind id e (a : action) =
+  match e with
+  | Lvar v when Ident.same v id -> a
+  | _ -> {a with binds = (kind, id, e) :: a.binds}
+
+let action_body_with ~fail {binds; guard; body} =
+  let core =
+    match guard with
+    | None -> body
+    | Some g -> if_ g body fail
+  in
+  List.fold_right (fun (k, id, e) acc -> let_ k id e acc) binds core
+
+(* For comparing actions by key. The stand-in for the fallthrough is a fresh
+   variable, shared by both sides so the keys stay comparable, and impossible
+   for a real action to mention. A constant such as unit would not do: it
+   would make [when g => e] and [_ => if g then e else ()] compare equal, and
+   merging those loses one evaluation of [g]. *)
+let action_key_term ~fail a = action_body_with ~fail a
+
+let action_free_variables {binds; guard; body} =
+  let inner =
+    match guard with
+    | None -> free_variables body
+    | Some g -> Set_ident.union (free_variables body) (free_variables g)
+  in
+  List.fold_right
+    (fun (_, id, e) acc ->
+      Set_ident.union (free_variables e) (Set_ident.remove acc id))
+    binds inner
+
 type pattern_matching = {
-  mutable cases: (pattern list * Lambda.t) list;
+  mutable cases: (pattern list * action) list;
   args: (Lambda.t * let_kind) list;
   default: (matrix * int) list;
 }
@@ -471,10 +519,9 @@ let same_actions = function
 
 (* Test for swapping two clauses *)
 
-let up_ok_action act1 act2 =
-  try
-    let raw1 = tr_raw act1 and raw2 = tr_raw act2 in
-    raw1 = raw2
+let up_ok_action (a1 : action) (a2 : action) =
+  let fail = Lambda.var (Ident.create "fallthrough") in
+  try tr_raw (action_key_term ~fail a1) = tr_raw (action_key_term ~fail a2)
   with Exit -> false
 
 let up_ok (ps, act_p) l =
@@ -514,7 +561,7 @@ let simplify_or p =
   try simpl_rec p with Var p -> p
 
 let bind_record_rest loc arg rest action =
-  let_ Strict rest.rest_ident
+  bind_action Strict rest.rest_ident
     (prim ~primitive:(Precord_rest rest.excluded_runtime_labels) ~args:[arg] loc)
     action
 
@@ -527,10 +574,10 @@ let simplify_cases args cls =
       | ((pat :: patl, action) as cl) :: rem -> (
         match pat.pat_desc with
         | Tpat_var (id, _) ->
-          (omega :: patl, bind Alias id arg action) :: simplify rem
+          (omega :: patl, bind_action Alias id arg action) :: simplify rem
         | Tpat_any -> cl :: simplify rem
         | Tpat_alias (p, id, _) ->
-          simplify ((p :: patl, bind Alias id arg action) :: rem)
+          simplify ((p :: patl, bind_action Alias id arg action) :: rem)
         | Tpat_record ([], _, rest) ->
           let action =
             match rest with
@@ -643,7 +690,7 @@ let rec explode_or_pat arg patl mk_action rem vars aliases = function
 
 let pm_free_variables {cases} =
   List.fold_right
-    (fun (_, act) r -> Set_ident.union (free_variables act) r)
+    (fun (_, act) r -> Set_ident.union (action_free_variables act) r)
     cases Set_ident.empty
 
 (* Basic grouping predicates *)
@@ -698,7 +745,7 @@ let is_or p =
 (* Conditions for appending to the Or matrix *)
 let conda p q = not (may_compat p q)
 
-and condb act ps qs = (not (is_guarded act)) && Parmatch.le_pats qs ps
+and condb (act : action) ps qs = act.guard = None && Parmatch.le_pats qs ps
 
 let or_ok p ps l =
   List.for_all
@@ -1046,7 +1093,7 @@ and precompile_or argo cls ors args def k =
         let new_patl = Parmatch.omega_list patl in
 
         let mk_new_action vs =
-          staticraise or_num (List.map (fun v -> var v) vs)
+          unguarded (staticraise or_num (List.map (fun v -> var v) vs))
         in
 
         let body, handlers = do_cases rem in
@@ -2416,11 +2463,15 @@ let arg_to_var arg cls =
 let rec compile_match repr partial ctx m =
   match m with
   | {cases = []; args = []} -> comp_exit ctx m
-  | {cases = ([], action) :: rem} ->
-    if is_guarded action then
-      let lambda, total = compile_match None partial ctx {m with cases = rem} in
-      (patch_guarded lambda action, total)
-    else (action, jumps_empty)
+  | {cases = ([], action) :: rem} -> (
+    (* The row matches. An unguarded action is the result; a guarded one
+       falls through to the remaining rows when the guard fails, so those
+       are compiled first and become the alternative. *)
+    match action.guard with
+    | None -> (action_body_with ~fail:lambda_unit action, jumps_empty)
+    | Some _ ->
+      let fail, total = compile_match None partial ctx {m with cases = rem} in
+      (action_body_with ~fail action, total))
   | {args = (arg, str) :: argl} ->
     let v, newarg = arg_to_var arg m.cases in
     let first_match, rem =
@@ -2568,7 +2619,7 @@ let check_partial is_mutable pat_act_list = function
       ||
       (* allow empty case list *)
       List.exists
-        (fun (pats, lam) -> is_mutable pats && is_guarded lam)
+        (fun (pats, (act : action)) -> is_mutable pats && act.guard <> None)
         pat_act_list
     then Partial
     else Total
@@ -2641,7 +2692,9 @@ let for_trywith param pat_act_list =
     param pat_act_list Partial
 
 let simple_for_let loc param pat body =
-  compile_matching None (partial_function loc) param [(pat, body)] Partial
+  compile_matching None (partial_function loc) param
+    [(pat, unguarded body)]
+    Partial
 
 (* Optimize binding of immediate tuples
 

compiler/ml/matching.mli

@@ -33,22 +33,27 @@ val make_test_sequence_variant_constant :
   (Lambda.t option -> Lambda.t -> (int * (string * Lambda.t)) list -> Lambda.t)
   ref
 
+(* A case's right-hand side. The guard is kept apart from the body until the
+   match compiler knows what it falls through to; it is not encoded as a term
+   to be recognized by shape later. *)
+type action
+
+val unguarded : Lambda.t -> action
+
+val guarded : guard:Lambda.t -> Lambda.t -> action
+
 (* Entry points to match compiler *)
 val for_function :
   Location.t ->
   int ref option ->
   Lambda.t ->
-  (pattern * Lambda.t) list ->
+  (pattern * action) list ->
   partial ->
   Lambda.t
-val for_trywith : Lambda.t -> (pattern * Lambda.t) list -> Lambda.t
+val for_trywith : Lambda.t -> (pattern * action) list -> Lambda.t
 val for_let : Location.t -> Lambda.t -> pattern -> Lambda.t -> Lambda.t
 val for_multiple_match :
-  Location.t ->
-  Lambda.t list ->
-  (pattern * Lambda.t) list ->
-  partial ->
-  Lambda.t
+  Location.t -> Lambda.t list -> (pattern * action) list -> partial -> Lambda.t
 
 exception Cannot_flatten
 

compiler/ml/translcore.ml

@@ -1300,10 +1300,10 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.t =
 and transl_list expr_list = List.map transl_exp expr_list
 
 and transl_guard guard rhs =
-  let expr = transl_exp rhs in
+  let body = transl_exp rhs in
   match guard with
-  | None -> expr
-  | Some cond -> if_ (transl_exp cond) expr staticfail
+  | None -> Matching.unguarded body
+  | Some cond -> Matching.guarded ~guard:(transl_exp cond) body
 
 and transl_case {c_lhs; c_guard; c_rhs} = (c_lhs, transl_guard c_guard c_rhs)
 
@@ -1384,13 +1384,15 @@ and transl_function loc (params : function_param list) body =
   | [{fp_param; fp_pat; fp_partial}] ->
     ( [fp_param],
       Matching.for_function loc None (var fp_param)
-        [(fp_pat, transl_exp body)]
+        [(fp_pat, Matching.unguarded (transl_exp body))]
         fp_partial,
       is_base_type body.exp_env body.exp_type Predef.path_unit )
   | {fp_param; fp_pat; fp_partial} :: rest ->
     let lparams, lbody, return_unit = transl_function loc rest body in
     ( fp_param :: lparams,
-      Matching.for_function loc None (var fp_param) [(fp_pat, lbody)] fp_partial,
+      Matching.for_function loc None (var fp_param)
+        [(fp_pat, Matching.unguarded lbody)]
+        fp_partial,
       return_unit )
 
 and transl_let ~js_hoist rec_flag pat_expr_list body =

tests/tests/src/guard_action_test.mjs

@@ -0,0 +1,31 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+
+let calls = {
+  contents: 0
+};
+
+function guard() {
+  calls.contents = calls.contents + 1 | 0;
+  return false;
+}
+
+function both_guards_run() {
+  calls.contents = 0;
+  if (guard()) {
+    
+  } else {
+    guard();
+  }
+  return calls.contents;
+}
+
+let constant_guard = "right";
+
+export {
+  constant_guard,
+  calls,
+  guard,
+  both_guards_run,
+}
+/* No side effect */

tests/tests/src/guard_action_test.res

@@ -0,0 +1,37 @@
+// A guard is kept apart from its body until the match compiler knows what it
+// falls through to. Two things must hold.
+
+// 1. Folding must not erase the fact that a case is guarded: a guard that
+//    folds to false is not a missing guard.
+let constant_guard = switch true {
+| true if false => "wrong"
+| _ => "right"
+}
+
+// 2. A guarded case and a case whose body happens to be the same conditional
+//    are different actions. Comparing them through a stand-in fallthrough must
+//    not equate them, or one evaluation of the guard is lost.
+type value = A | B | C
+
+let calls = ref(0)
+
+let guard = () => {
+  calls := calls.contents + 1
+  false
+}
+
+let both_guards_run = () => {
+  calls := 0
+  switch B {
+  | A => ()
+  | _ if guard() => ()
+  | B =>
+    if guard() {
+      ()
+    } else {
+      ()
+    }
+  | _ => ()
+  }
+  calls.contents
+}