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