Refactor Ielr1.ipred_transit_kernel_attribs

bootstrap/bin/hocc/ielr1.ml

@@ -4,7 +4,7 @@ open! Basis.Rudiments
 let rec ipred_transit_kernel_attribs ~resolve symbols prods lalr1_states adjs ~lalr1_kernel_attribs
     lanectx =
   let state_index = State.index (LaneCtx.state lanectx) in
-  (* Accumulate kernel attribs of `lanectx`. *)
+  (* Accumulate kernel attribs of ipred lane contexts. *)
   Array.fold ~init:lalr1_kernel_attribs
     ~f:(fun lalr1_kernel_attribs ipred_state_index ->
       let ipred_state = Array.get ipred_state_index lalr1_states in
@@ -17,25 +17,39 @@ let rec ipred_transit_kernel_attribs ~resolve symbols prods lalr1_states adjs ~l
         Ordmap.get transit lalr1_kernel_attribs
         |> Option.value ~default:KernelAttribs.empty
       in
-      (* Detect the no-op case as quickly as possible. The conceptually simpler approach of doing
-       * the insertion and diffing before/after kernel attribs is a lot more expensive. *)
-      let do_insert = KernelAttribs.for_any ~f:(fun (lr1item, attribs) ->
-        match KernelAttribs.get lr1item kernel_attribs with
-        | None -> true
-        | Some attribs_prev -> begin
-            Attribs.for_any ~f:(fun (Attrib.{conflict_state_index; symbol_index; _} as attrib) ->
-              match Attribs.get ~conflict_state_index ~symbol_index attribs_prev with
-              | None -> true
-              | Some attrib_prev -> not Attrib.(is_empty (diff attrib attrib_prev))
-            ) attribs
-          end
-      ) ipred_kernel_attribs in
+      (* Manually compute the union of `kernel_attribs` and `ipred_kernel_attribs` such that
+       * `do_insert` is false if the union equals `kernel_attribs`, i.e. insertion into
+       * `lalr1_kernel_attribs` would be a no-op. The conceptually simpler approach of computing the
+       * union via `KernelAttribs.union` and checking equality of before/after kernel attribs is a
+       * lot more expensive for the no-op (equal) case. *)
+      let do_insert, kernel_attribs' = KernelAttribs.fold ~init:(false, kernel_attribs)
+        ~f:(fun (do_insert, kernel_attribs') (lr1item, attribs) ->
+          match KernelAttribs.get lr1item kernel_attribs with
+          | None -> true, KernelAttribs.insert lr1item attribs kernel_attribs'
+          | Some attribs_prev -> begin
+              Attribs.fold ~init:(do_insert, kernel_attribs')
+                ~f:(fun (do_insert, kernel_attribs')
+                  (Attrib.{conflict_state_index; symbol_index; _} as attrib) ->
+                  match Attribs.get ~conflict_state_index ~symbol_index attribs_prev with
+                  | None ->
+                    true, KernelAttribs.insert lr1item (Attribs.singleton attrib) kernel_attribs'
+                  | Some attrib_prev -> begin
+                      let attrib' = Attrib.diff attrib attrib_prev in
+                      match Attrib.is_empty attrib' with
+                      | true -> do_insert, kernel_attribs'
+                      | false -> begin
+                          true,
+                          KernelAttribs.insert lr1item (Attribs.singleton attrib') kernel_attribs'
+                        end
+                    end
+                ) attribs
+            end
+        ) ipred_kernel_attribs in
       (* Avoid recursing if no new transit attribs are inserted, since no additional insertions
        * will occur in the recursion. *)
       match do_insert with
       | false -> lalr1_kernel_attribs
       | true -> begin
-          let kernel_attribs' = KernelAttribs.union ipred_kernel_attribs kernel_attribs in
           let lalr1_kernel_attribs =
             Ordmap.upsert ~k:transit ~v:kernel_attribs' lalr1_kernel_attribs in
           (* Recurse if lanes may extend to predecessors. *)