From 277913f40d88ec427d772deba882115928766478 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 27 Jul 2026 09:49:46 +0200 Subject: [PATCH] feat(ir): choose case columns by Maranget's pbaN composite Replace the single-metric column selection in matchChosenByHeuristic (pick the match tested by the most other clauses) with the pbaN composite from Maranget's "Compiling Pattern Matching to Good Decision Trees", adapted to the clause-per-row representation: maximise the needed prefix (p), then minimise distinct patterns on the column (b), then minimise the sub-tests those patterns expose (a), tie-breaking leftmost (N). Surrounding decision-tree construction and MatchHistory pruning are unchanged. On matrices where the metrics disagree the composite emits a smaller tree: the new unit test's five-clause matrix compiles to 8 tests instead of 9. Corpus impact is a neutral test-order swap in Golden.CasePruning.Test only; eval goldens and bench counters are unchanged. Closes #237 --- ...727_100000_unisay_pban_column_heuristic.md | 9 +++ lib/Language/PureScript/Backend/IR.hs | 70 ++++++++++++------- test/Language/PureScript/Backend/IR/Spec.hs | 70 +++++++++++++++++++ .../output/Golden.CasePruning.Test/golden.ir | 8 +-- .../output/Golden.CasePruning.Test/golden.lua | 8 +-- 5 files changed, 132 insertions(+), 33 deletions(-) create mode 100644 changelog.d/20260727_100000_unisay_pban_column_heuristic.md diff --git a/changelog.d/20260727_100000_unisay_pban_column_heuristic.md b/changelog.d/20260727_100000_unisay_pban_column_heuristic.md new file mode 100644 index 00000000..383e91a6 --- /dev/null +++ b/changelog.d/20260727_100000_unisay_pban_column_heuristic.md @@ -0,0 +1,9 @@ +### Changed + +- Case expressions choose the next column to test by Maranget's `pbaN` + composite ("Compiling Pattern Matching to Good Decision Trees"): the column + needed by the longest prefix of remaining clauses wins, ties fall to the + column with the fewest distinct patterns, then the fewest exposed sub-tests, + then the leftmost. The previous single metric — the column tested by the + most other clauses — could re-test a wide column inside every branch of a + narrow one, emitting a larger decision tree (#237). diff --git a/lib/Language/PureScript/Backend/IR.hs b/lib/Language/PureScript/Backend/IR.hs index e16d1925..031f9cc9 100644 --- a/lib/Language/PureScript/Backend/IR.hs +++ b/lib/Language/PureScript/Backend/IR.hs @@ -29,7 +29,7 @@ import Language.PureScript.PSString , decodeString , decodeStringEscaping ) -import Relude.Extra (toFst) +import Relude.Extra (minimumOn1) import Text.Megaparsec qualified as Megaparsec import Text.Pretty.Simple (pShow) import Text.Show (Show (..)) @@ -544,9 +544,16 @@ the shared binding each use would re-emit (and the codegen re-evaluate) the whole expression. String, array, and object scrutinees are bound too. Column-selection heuristic ('matchChosenByHeuristic'): when a clause has -several outstanding matches, pick the one shared by the most other clauses -('countAffectedClauses'). Testing a shared sub-value first lets one test serve -many clauses, which keeps the tree small. +several outstanding matches, the column to test next (a column is a focused +sub-value: scrutinee plus 'stepsToFocus') is chosen by Maranget's pbaN +composite ("Compiling Pattern Matching to Good Decision Trees", ML'08), +adapted to this clause-per-row representation. Maximise p, the number of +consecutive clauses starting from the current one that test the column — a +test every following clause needs cannot be wasted; break ties by minimal +b, the number of distinct patterns tested on the column across all +remaining clauses — a column with fewer distinct tests is retired sooner; +then by minimal a, the number of sub-tests those patterns expose once +passed — the cheaper look-ahead; finally leftmost (N). Match-history pruning ('MatchHistory'): every test emitted on a given scrutinee — a constructor tag, a literal equality, an array length — is @@ -690,29 +697,42 @@ matchChosenByHeuristic thisClause otherClauses = case clauseMatches thisClause of [] → Nothing [match] → Just (match, thisClause {clauseMatches = []}) - matches → - -- select a match that is present in the maximum number of other clauses - sortOn - (Down . fst) - (toFst (countAffectedClauses otherClauses) <$> matches) - & uncons - & fmap \(match, remainingMatches) → - (snd match, thisClause {clauseMatches = snd <$> remainingMatches}) + matches → do + indexed ← nonEmpty (zip [0 ∷ Int ..] matches) + let bestIndex = fst $ minimumOn1 (\(i, m) → (score m, i)) indexed + (chosen, after) ← uncons (drop bestIndex matches) + pure (chosen, thisClause {clauseMatches = take bestIndex matches <> after}) where - countAffectedClauses ∷ [CaseClause] → Match → Int - countAffectedClauses clauses Match {matchExp = expr, stepsToFocus = steps} = - foldr count 0 clauses + -- The pbaN composite, ordered so that the minimal score wins: + -- maximal needed prefix (p), fewest distinct patterns tested on the + -- column (b), fewest sub-tests those patterns expose once passed (a). + -- Pairing the score with the match position resolves ties to the + -- leftmost match (N). + score ∷ Match → (Down Int, Int, Int) + score Match {matchExp = expr, stepsToFocus = steps} = + ( Down (length (takeWhile (not . Map.null) rows)) + , Map.size column + , sum column + ) + where + -- Per clause: the patterns it tests on the column, each mapped to + -- the number of sub-tests it exposes (a pattern determines its + -- sub-test count, so the maps agree on shared keys). + rows ∷ [Map Pattern Int] + rows = + clauseForests <&> \forest → + Map.fromList + [ (matchPat, length nestedMatches) + | Match {matchExp, stepsToFocus, matchPat, nestedMatches} ← forest + , matchPat /= PatAny + , matchExp == expr + , stepsToFocus == steps + ] + column = Map.unions rows + + clauseForests ∷ [[Match]] + clauseForests = allClauseMatches <$> (thisClause : otherClauses) where - count ∷ CaseClause → Int → Int - count clause counter = - maybe counter (\_ → counter + 1) $ - allClauseMatches clause & find \case - Match {matchPat = PatAny} → False - Match {matchExp, stepsToFocus} - | matchExp == expr, stepsToFocus == steps → True - _ → False - - allClauseMatches ∷ CaseClause → [Match] allClauseMatches CaseClause {clauseMatches} = go [] clauseMatches where go acc = \case diff --git a/test/Language/PureScript/Backend/IR/Spec.hs b/test/Language/PureScript/Backend/IR/Spec.hs index 05b80933..1de48c91 100644 --- a/test/Language/PureScript/Backend/IR/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Spec.hs @@ -711,6 +711,76 @@ spec = describe "IR representation" do ) ) + it "tests the column with fewer distinct patterns first" do + {- + + Five clauses over two columns; every clause tests both columns + (equal neededness), but column 1 carries four distinct tests + ('a'/'b'/'c'/'d') while column 2 carries two ('p'/'q'): + + case 'x', 'y' of + 'a', 'p' -> 1 + 'b', 'p' -> 2 + 'c', 'p' -> 3 + 'd', 'p' -> 4 + 'a', 'q' -> 5 + + Testing column 2 first retires it after one test per branch and + the column-1 chain follows once per outcome — 8 tests. Testing + column 1 first re-tests column 2 inside every branch of the + four-way chain — 9 tests. + + -} + representedCase + [cfnCharE 'x', cfnCharE 'y'] + [ Cfn.CaseAlternative + { caseAlternativeBinders = + [cfnLitB (cfnCharL c1), cfnLitB (cfnCharL c2)] + , caseAlternativeResult = Right $ cfnInt r + } + | (c1, c2, r) ← + [ ('a', 'p', 1) + , ('b', 'p', 2) + , ('c', 'p', 3) + , ('d', 'p', 4) + , ('a', 'q', 5) + ] + ] + >>= ( `shouldBe` + ifThenElse + (literalChar 'p' `eq` literalChar 'y') + ( ifThenElse + (literalChar 'a' `eq` literalChar 'x') + (literalInt 1) + ( ifThenElse + (literalChar 'b' `eq` literalChar 'x') + (literalInt 2) + ( ifThenElse + (literalChar 'c' `eq` literalChar 'x') + (literalInt 3) + ( ifThenElse + (literalChar 'd' `eq` literalChar 'x') + (literalInt 4) + (exception "No patterns matched") + ) + ) + ) + ) + ( ifThenElse + (literalChar 'd' `eq` literalChar 'x') + (exception "No patterns matched") + ( ifThenElse + (literalChar 'a' `eq` literalChar 'x') + ( ifThenElse + (literalChar 'q' `eq` literalChar 'y') + (literalInt 5) + (exception "No patterns matched") + ) + (exception "No patterns matched") + ) + ) + ) + describe "collectDataDeclarations" do it "classifies data types regardless of constructor order" do let cfnCtor tyName ctorName = diff --git a/test/ps/output/Golden.CasePruning.Test/golden.ir b/test/ps/output/Golden.CasePruning.Test/golden.ir index f4f0a34c..95a1808b 100644 --- a/test/ps/output/Golden.CasePruning.Test/golden.ir +++ b/test/ps/output/Golden.CasePruning.Test/golden.ir @@ -87,9 +87,9 @@ UberModule ) ) ( IfThenElse Nothing - ( Eq Nothing ( LiteralInt Nothing 2 ) ( Ref Nothing ( Local ( Name "v" ) ) ) ) + ( Eq Nothing ( LiteralInt Nothing 2 ) ( Ref Nothing ( Local ( Name "v1" ) ) ) ) ( IfThenElse Nothing - ( Eq Nothing ( LiteralInt Nothing 2 ) ( Ref Nothing ( Local ( Name "v1" ) ) ) ) + ( Eq Nothing ( LiteralInt Nothing 2 ) ( Ref Nothing ( Local ( Name "v" ) ) ) ) ( LiteralInt Nothing 2 ) ( LiteralInt Nothing 4 ) ) @@ -139,12 +139,12 @@ UberModule ( IfThenElse Nothing ( Eq Nothing ( LiteralString Nothing "Golden.CasePruning.Test∷T.B" ) - ( Ref Nothing ( Local ( Name "$cse248" ) ) ) + ( Ref Nothing ( Local ( Name "$cse249" ) ) ) ) ( IfThenElse Nothing ( Eq Nothing ( LiteralString Nothing "Golden.CasePruning.Test∷T.B" ) - ( Ref Nothing ( Local ( Name "$cse249" ) ) ) + ( Ref Nothing ( Local ( Name "$cse248" ) ) ) ) ( LiteralInt Nothing 2 ) ( LiteralInt Nothing 4 ) diff --git a/test/ps/output/Golden.CasePruning.Test/golden.lua b/test/ps/output/Golden.CasePruning.Test/golden.lua index 3b5af16b..67da5200 100644 --- a/test/ps/output/Golden.CasePruning.Test/golden.lua +++ b/test/ps/output/Golden.CasePruning.Test/golden.lua @@ -17,8 +17,8 @@ local Golden_CasePruning_Test_literalNegatives = function(v) return function(v1) if 1 == v then if 1 == v1 then return 1 elseif 2 == v1 then return 3 else return 4 end - elseif 2 == v then - if 2 == v1 then return 2 else return 4 end + elseif 2 == v1 then + if 2 == v then return 2 else return 4 end else return 4 end @@ -36,8 +36,8 @@ local Golden_CasePruning_Test_ctorRetest = function(v) else return 4 end - elseif "Golden.CasePruning.Test∷T.B" == _S_cse1 then - if "Golden.CasePruning.Test∷T.B" == _S_cse0 then + elseif "Golden.CasePruning.Test∷T.B" == _S_cse0 then + if "Golden.CasePruning.Test∷T.B" == _S_cse1 then return 2 else return 4