Skip to content

Choose case columns by Maranget's pbaN composite #311

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
Unisay merged 1 commit into from
Jul 27, 2026
Merged

Choose case columns by Maranget's pbaN composite #311

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
9 changes: 9 additions & 0 deletions changelog.d/20260727_100000_unisay_pban_column_heuristic.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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).
70 changes: 45 additions & 25 deletions lib/Language/PureScript/Backend/IR.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..))
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
70 changes: 70 additions & 0 deletions test/Language/PureScript/Backend/IR/Spec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
8 changes: 4 additions & 4 deletions test/ps/output/Golden.CasePruning.Test/golden.ir
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 )
)
Expand Down Expand Up @@ -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 )
Expand Down
8 changes: 4 additions & 4 deletions test/ps/output/Golden.CasePruning.Test/golden.lua
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down