Normalize Lambda terms where they are built

CHANGELOG.md

@@ -68,6 +68,7 @@
 
 #### :house: Internal
 
+- Normalize Lambda terms where they are built: a match guard stays structured data until its fallthrough is known, and `apply` and `mk_builtin` go through the folding constructors. https://github.com/rescript-lang/rescript/pull/8615
 - Merge the duplicate Lam intermediate representation into Lambda, removing the conversion layer and obsolete supporting infrastructure. Lambda is now a single private, normalized representation, with generated JavaScript remaining semantically unchanged. https://github.com/rescript-lang/rescript/pull/8608
 - Add genType and source map controls and output to the developer playground. https://github.com/rescript-lang/rescript/pull/8448
 - Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597

compiler/ml/lambda.ml

@@ -769,61 +769,6 @@ let rec is_eta_conversion_exn params inner_args outer_args : t list =
   | [], [], [] -> []
   | _, _, _ -> raise_notrace Not_simple_form
 
-let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t =
-  match fn with
-  | Lfunction
-      {
-        params;
-        body =
-          Lprim
-            {
-              primitive =
-                ( Pnull_to_opt | Pnull_undefined_to_opt | Pis_null
-                | Pis_null_undefined | Ptypeof ) as wrap;
-              args =
-                [Lprim ({primitive = _; args = inner_args} as primitive_call)];
-            };
-      } -> (
-    match is_eta_conversion_exn params inner_args args with
-    | args ->
-      let loc = ap_info.ap_loc in
-      Lprim
-        {primitive = wrap; args = [Lprim {primitive_call with args; loc}]; loc}
-    | exception Not_simple_form ->
-      Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx})
-  | Lfunction
-      {
-        params;
-        body = Lprim ({primitive = _; args = inner_args} as primitive_call);
-      } -> (
-    match is_eta_conversion_exn params inner_args args with
-    | args -> Lprim {primitive_call with args; loc = ap_info.ap_loc}
-    | exception _ ->
-      Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx})
-  | Lfunction
-      {
-        params;
-        body =
-          Lsequence
-            ( Lprim ({primitive = _; args = inner_args} as primitive_call),
-              (Lconst _ as const) );
-      } -> (
-    match is_eta_conversion_exn params inner_args args with
-    | args ->
-      Lsequence (Lprim {primitive_call with args; loc = ap_info.ap_loc}, const)
-    | exception _ ->
-      Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}
-      (* | Lfunction {params;body} when Ext_list.same_length params args ->
-          Ext_list.fold_right2 (fun p arg acc ->
-            Llet(Strict,p,arg,acc)
-          ) params args body *)
-      (* TODO: more rigirous analysis on [let_kind] *))
-  | Llet (kind, id, e, (Lfunction _ as fn)) ->
-    Llet (kind, id, e, apply fn args ap_info ~ap_transformed_jsx)
-  (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) ->
-     Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *)
-  | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}
-
 let rec eq_approx (l1 : t) (l2 : t) =
   match l1 with
   | Lglobal_module i1 -> (
@@ -1080,6 +1025,62 @@ let prim ~primitive:(prim : primitive) ~args loc : t =
     *)
     | _ -> default ())
 
+let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t =
+  match fn with
+  | Lfunction
+      {
+        params;
+        body =
+          Lprim
+            {
+              primitive =
+                ( Pnull_to_opt | Pnull_undefined_to_opt | Pis_null
+                | Pis_null_undefined | Ptypeof ) as wrap;
+              args =
+                [Lprim ({primitive = _; args = inner_args} as primitive_call)];
+            };
+      } -> (
+    match is_eta_conversion_exn params inner_args args with
+    | args ->
+      let loc = ap_info.ap_loc in
+      prim ~primitive:wrap
+        ~args:[prim ~primitive:primitive_call.primitive ~args loc]
+        loc
+    | exception Not_simple_form ->
+      Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx})
+  | Lfunction
+      {
+        params;
+        body = Lprim ({primitive = _; args = inner_args} as primitive_call);
+      } -> (
+    match is_eta_conversion_exn params inner_args args with
+    | args -> prim ~primitive:primitive_call.primitive ~args ap_info.ap_loc
+    | exception _ ->
+      Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx})
+  | Lfunction
+      {
+        params;
+        body =
+          Lsequence
+            ( Lprim ({primitive = _; args = inner_args} as primitive_call),
+              (Lconst _ as const) );
+      } -> (
+    match is_eta_conversion_exn params inner_args args with
+    | args ->
+      seq (prim ~primitive:primitive_call.primitive ~args ap_info.ap_loc) const
+    | exception _ ->
+      Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}
+      (* | Lfunction {params;body} when Ext_list.same_length params args ->
+          Ext_list.fold_right2 (fun p arg acc ->
+            Llet(Strict,p,arg,acc)
+          ) params args body *)
+      (* TODO: more rigirous analysis on [let_kind] *))
+  | Llet (kind, id, e, (Lfunction _ as fn)) ->
+    let_ kind id e (apply fn args ap_info ~ap_transformed_jsx)
+  (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) ->
+     Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *)
+  | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}
+
 let not_ loc x : t =
   match x with
   | Lprim ({primitive = Pintcomp Cneq} as prim) ->
@@ -1263,7 +1264,7 @@ let sequand l r = if_ l r lambda_false
 
 let mk_builtin b args loc =
   match b with
-  | Primitive p -> Lprim {primitive = p; args; loc}
+  | Primitive p -> prim ~primitive:p ~args loc
   | Constant c -> (
     match args with
     | [] -> Lconst c
@@ -1457,19 +1458,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