git.iko.soy/elk
on master help sign in
First draft of pattern-match-compiler revamp
00e87d2Evan Czaplicki
src/Optimize/Cases.hs+346−201
compare with master
unifiedsplit
@@ -1,266 +1,411 @@
1−module Optimize.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where
1+module Optimize.Cases where
2+{- To learn more about how this works, definitely read through:
2
3
3−import Control.Applicative ((<$>))
4+ "When Do Match-Compilation Heuristics Matter?"
5+
6+by Kevin Scott and Norman Ramsey. The rough idea is that we start with a simple
7+list of patterns and expressions, and then turn that into a "decision tree"
8+that requires as few tests as possible to make it to a leaf. Read the paper, it
9+explains this extraordinarily well! We are currently using the same heuristics
10+as SML/NJ to get nice trees.
11+
12+Users of this module will mainly interact with the 'compile' function which
13+takes some normal branches and gives out a decision tree that has "labels" at
14+all the leafs and a dictionary that maps these "labels" to the code that
15+should run.
16+
17+If 2 or more leaves point to the same label, we need to do some tricks in JS to
18+make that work nicely. When is JS getting goto?! ;)
19+-}
20+
21+
4−import Control.Arrow (first)
22+import Control.Arrow (second)
5−import Control.Monad.State (State)
23+import Data.Function (on)
6−import qualified Control.Monad.State as State
7import qualified Data.List as List
24import qualified Data.List as List
8−import Data.Maybe (fromMaybe)
25+import qualified Data.Map as Map
26+import Data.Map ((!))
27+import qualified Data.Maybe as Maybe
9
28
10−import qualified AST.Expression.General as Expr
29+import qualified AST.Expression.Optimized as Opt
11−import qualified AST.Expression.Optimized as Optimized
12−import qualified AST.Literal as Literal
30+import qualified AST.Literal as L
13import qualified AST.Pattern as P
31import qualified AST.Pattern as P
14import qualified AST.Variable as Var
32import qualified AST.Variable as Var
15−import qualified Optimize.Substitute as S
16import qualified Reporting.Annotation as A
33import qualified Reporting.Annotation as A
17
34
18
35
19−-- MATCHES
36+-- COMPILE CASES
37+
38+compile
39+ :: VariantDict
40+ -> [(OPattern, Opt.Expr)]
41+ -> (DecisionTree Int, Map.Map Int Opt.Expr)
42+compile variantDict rawBranches =
43+ let
44+ format index (pattern, expr) =
45+ ( Branch index [(Empty, pattern)]
46+ , (index, expr)
47+ )
48+
49+ (branches, resultList) =
50+ unzip (zipWith format [0..] rawBranches)
51+ in
52+ ( toDecisionTree variantDict branches
53+ , Map.fromList resultList
54+ )
55+
56+
57+-- DECISION TREES
58+
59+data DecisionTree a
60+ = Test
61+ { _test :: Path
62+ , _edges :: [(Tag, DecisionTree a)]
63+ , _default :: Maybe (DecisionTree a)
64+ }
65+ | Match
66+ { result :: a
67+ , substitutions :: Map.Map String Path
68+ }
69+
70+
71+-- EDGE CHECKS
72+
73+data Tag
74+ = Constructor Var.Canonical
75+ | Literal L.Literal
76+ deriving (Eq, Ord)
77+
78+
79+-- PATHS
80+
81+data Path
82+ = Position Int Path
83+ | Field String Path
84+ | Empty
85+ | Alias
86+ deriving (Eq)
87+
20
88
21−data Match
89+add :: Path -> Path -> Path
22− = Match String [Clause] Match
90+add path finalLink =
23− | Break
91+ case path of
24− | Fail
92+ Empty ->
25− | Other Optimized.Expr
93+ finalLink
26− | Seq [Match]
27− deriving (Show)
28
94
95+ Alias ->
96+ error "nothing should be added to an alias path"
29
97
30−data Clause =
98+ Position index subpath ->
31− Clause (Either Var.Canonical Literal.Literal) [String] Match
99+ Position index (add subpath finalLink)
32− deriving (Show)
33
100
101+ Field name subpath ->
102+ Field name (add subpath finalLink)
34
103
35−type Branch =
36− ([P.Optimized], Optimized.Expr)
37
104
105+subPositions :: Path -> [OPattern] -> [(Path, OPattern)]
106+subPositions path patterns =
107+ zipWith
108+ (\index pattern -> (add path (Position index Empty), pattern))
109+ [0..]
110+ patterns
38
111
39−-- PUBLIC FUNCTIONS
40
112
41−toMatch :: [(P.Optimized, Optimized.Expr)] -> State Int (String, Match)
113+-- CREATE DECISION TREES
42−toMatch patterns =
43− do v <- newVar
44− (,) v <$> buildMatch [v] (map (first (:[])) patterns) Fail
45
114
46
115
47−newVar :: State Int String
116+data Branch =
48−newVar =
117+ Branch
49− do n <- State.get
118+ { _goal :: Int
50− State.modify (+1)
119+ , _patterns :: [(Path, OPattern)]
51− return $ "_v" ++ show n
120+ }
52
121
53
122
54−matchSubst :: [(String,String)] -> Match -> Match
123+type OPattern = P.Optimized
55−matchSubst pairs match =
56− case match of
57− Break -> Break
58
124
59− Fail -> Fail
60
125
61− Seq ms ->
126+type VariantDict = Map.Map Var.Canonical Int
62− Seq (map (matchSubst pairs) ms)
63
127
64− Other (A.A ann expr) ->
128+
129+-- BUILD A DECISION TREE
130+
131+toDecisionTree :: VariantDict -> [Branch] -> DecisionTree Int
132+toDecisionTree variantDict rawBranches =
133+ let
134+ branches =
135+ map (skipUselessPatterns variantDict) rawBranches
136+ in
137+ case isAllValiables branches of
138+ Just (goal, substitutions) ->
139+ Match goal substitutions
140+
141+ Nothing ->
65 let
142 let
66− substitutions =
143+ path =
67− map (\(x,y) -> S.subst x (Expr.localVar y)) pairs
144+ smallDefaults branches
145+
146+ relevantTags =
147+ tagsAtPath path branches
148+
149+ allRawEdges =
150+ map (edgesFor path branches) relevantTags
151+
152+ (rawEdges, unexplored) =
153+ if isComplete variantDict relevantTags then
154+ ( init allRawEdges
155+ , snd (last allRawEdges)
156+ )
157+
158+ else
159+ ( allRawEdges
160+ , filter (isIrrelevantTo path) branches
161+ )
162+
163+ edges =
164+ map (second (toDecisionTree variantDict)) rawEdges
68 in
165 in
69− Other $ A.A ann $ foldr ($) expr substitutions
166+ case (edges, unexplored) of
167+ ([(_tag, decisionTree)], []) ->
168+ decisionTree
70
169
71− Match n cs m ->
170+ (_, []) ->
72− Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
171+ Test path edges Nothing
73− where
74− varSubst v = fromMaybe v (lookup v pairs)
75− clauseSubst (Clause c vs m) =
76− Clause c (map varSubst vs) (matchSubst pairs m)
77
172
173+ (_, _) ->
174+ Test path edges (Just (toDecisionTree variantDict unexplored))
78
175
79−-- BUILD MATCHES
80
176
81−buildMatch :: [String] -> [Branch] -> Match -> State Int Match
177+isComplete :: VariantDict -> [Tag] -> Bool
82−buildMatch variables branches match =
178+isComplete variantDict tags =
83− case (variables, branches, match) of
179+ case head tags of
84− ([], [], _) ->
180+ Constructor name ->
85− return match
181+ (variantDict ! name) == length tags
86
182
87− ([], [([], expr)], Fail) ->
183+ Literal (L.Boolean _) ->
88− return $ Other expr
184+ length tags == 2
89
185
90− ([], [([], expr)], Break) ->
186+ _ ->
91− return $ Other expr
187+ False
92
188
93− ([], _, _) ->
94− return $ Seq (map (Other . snd) branches ++ [match])
95
189
96− (var:_, _, _)
97− | all isVar branches' -> matchVar variables branches' match
98− | all isCon branches' -> matchCon variables branches' match
99− | otherwise -> matchMix variables branches' match
100− where
101− branches' = map (dealias var) branches
102
190
191+-- SKIP USELESS TESTS
103
192
104−dealias :: String -> Branch -> Branch
193+skipUselessPatterns :: VariantDict -> Branch -> Branch
105−dealias _ ([], _) = noMatch "dealias"
194+skipUselessPatterns variantDict (Branch goal pathPatterns) =
106−dealias var branch@(p:ps, A.A ann e) =
195+ Branch goal (concatMap (skipper variantDict) pathPatterns)
107− case p of
108− A.A _ (P.Alias alias pattern) ->
109− ( pattern:ps
110− , A.A ann (S.subst alias (Expr.localVar var) e)
111− )
112
196
113− _ ->
114− branch
115
197
198+skipper :: VariantDict -> (Path, OPattern) -> [(Path, OPattern)]
199+skipper variantDict pathPattern@(path, A.A ann pattern) =
200+ case pattern of
201+ P.Var _ ->
202+ [pathPattern]
116
203
117−isCon :: ([P.Pattern ann var], expr) -> Bool
204+ P.Anything ->
118−isCon ([], _) = noMatch "isCon"
205+ [pathPattern]
119−isCon (A.A _ pattern : _, _) =
120− case pattern of
121− P.Data _ _ -> True
122− P.Literal _ -> True
123− _ -> False
124
206
207+ P.Alias alias realPattern ->
208+ [ (add path Alias, A.A ann (P.Var alias))
209+ , (path, realPattern)
210+ ]
125
211
126−isVar :: ([P.Pattern ann var], expr) -> Bool
212+ P.Record _ ->
127−isVar p =
213+ [pathPattern]
128− not (isCon p)
129
214
215+ P.Data tag patterns ->
216+ if variantDict ! tag == 1 then
217+ concatMap (skipper variantDict) (subPositions path patterns)
130
218
131−-- VARIABLE MATCHES
219+ else
220+ [pathPattern]
132
221
133−matchVar :: [String] -> [Branch] -> Match -> State Int Match
222+ P.Literal _ ->
134−matchVar [] _ _ = noMatch "matchVar"
223+ [pathPattern]
135−matchVar (var:vars) branches match =
224+
136− buildMatch vars (map subVar branches) match
225+
137− where
226+-- VARIABLE SUBSTITUTIONS
138− subVar ([], _) = noMatch "matchVar.subVar"
227+
139− subVar (A.A _ pattern : patterns, (A.A ann expr)) =
228+isAllValiables :: [Branch] -> Maybe (Int, Map.Map String Path)
140− ( patterns
229+isAllValiables branches =
141− , A.A ann (subOnePattern pattern expr)
230+ case branches of
142− )
231+ Branch goal patterns : _ ->
143− where
232+ do subs <- concat `fmap` mapM getSubstitution patterns
144− subOnePattern pattern expr =
233+ return (goal, Map.fromList subs)
234+
235+ _ ->
236+ Nothing
237+
238+
239+getSubstitution :: (Path, OPattern) -> Maybe [(String, Path)]
240+getSubstitution (path, A.A _ pattern) =
145− case pattern of
241+ case pattern of
242+ P.Var x ->
243+ Just [(x, path)]
244+
146− P.Anything ->
245+ P.Anything ->
147− expr
246+ Just []
148−
247+
149− P.Var x ->
248+ P.Alias _ _ ->
150− S.subst x (Expr.localVar var) expr
249+ error "aliases should never reach 'getSubstitution' function"
151−
250+
152− P.Record fields ->
251+ P.Record fields ->
153− let access = Expr.Access (A.A ann (Expr.localVar var))
252+ Just (map (\name -> (name, add path (Field name Empty))) fields)
154− in
253+
155− foldr (\x -> S.subst x (access x)) expr fields
156−
157− _ ->
158− noMatch "matchVar.subVar"
159−
160−
161−-- CONSTRUCTOR MATCHES
162−
163−matchCon :: [String] -> [Branch] -> Match -> State Int Match
164−matchCon variables branches match =
165− case variables of
166− [] -> noMatch "matchCon"
167−
168− var : _vars ->
169− flip (Match var) match <$> mapM toClause caseGroups
170− where
171− caseGroups :: [[Branch]]
172− caseGroups =
173− List.groupBy branchEq (List.sortBy branchCmp branches)
174−
175− toClause :: [Branch] -> State Int Clause
176− toClause branches =
177− case head branches of
178− (A.A _ (P.Data name _) : _, _) ->
254+ P.Data _ _ ->
179− matchClause (Left name) variables branches Break
255+ Nothing
180−
256+
181− (A.A _ (P.Literal lit) : _, _) ->
257+ P.Literal _ ->
182− matchClause (Right lit) variables branches Break
258+ Nothing
183−
259+
184− _ -> noMatch "matchCon"
260+
185−
261+-- FIND RELEVANT TAGS
186−
262+
187−matchClause
188− :: Either Var.Canonical Literal.Literal
189− -> [String]
190− -> [Branch]
263+tagsAtPath :: Path -> [Branch] -> [Tag]
191− -> Match
264+tagsAtPath selectedPath branches =
192− -> State Int Clause
265+ List.nub $ Maybe.mapMaybe (tagAtPath selectedPath) branches
193−matchClause _ [] _ _ = noMatch "matchClause"
266+
194−matchClause c (_:vs) branches match =
267+
195− do vs' <- getVars
268+tagAtPath :: Path -> Branch -> Maybe Tag
196− Clause c vs' <$> buildMatch (vs' ++ vs) (map flatten branches) match
269+tagAtPath selectedPath (Branch _ pathPatterns) =
197− where
270+ case List.lookup selectedPath pathPatterns of
198− flatten ([], _) = noMatch "matchClause.flatten"
271+ Nothing ->
272+ Nothing
273+
199− flatten (A.A _ pattern : patterns, expr) =
274+ Just (A.A _ pattern) ->
200 case pattern of
275 case pattern of
201− P.Data _ argPatterns ->
276+ P.Data name _ ->
202− (argPatterns ++ patterns, expr)
277+ Just (Constructor name)
203
278
204− P.Literal _ ->
279+ P.Literal lit ->
205− (patterns, expr)
280+ Just (Literal lit)
281+
282+ P.Var _ ->
283+ Nothing
284+
285+ P.Alias _ _ ->
286+ error "aliases should never reach 'tagAtPath' function"
287+
288+ P.Anything ->
289+ Nothing
290+
291+ P.Record _ ->
292+ Nothing
293+
294+
295+-- BUILD EDGES
296+
297+edgesFor :: Path -> [Branch] -> Tag -> (Tag, [Branch])
298+edgesFor path branches tag =
299+ ( tag
300+ , Maybe.mapMaybe (subBranch tag path) branches
301+ )
206
302
207− _ ->
208− noMatch "matchClause.flatten"
209
303
210− getVars :: State Int [String]
304+subBranch :: Tag -> Path -> Branch -> Maybe Branch
211− getVars =
305+subBranch tag path branch@(Branch goal pathPatterns) =
212− case head branches of
306+ case extract path pathPatterns of
213− (A.A _ (P.Data _ argPatterns) : _, _) ->
307+ Just (start, A.A _ pattern, end) ->
214− State.forM argPatterns (const newVar)
308+ case pattern of
309+ P.Data name patterns | tag == Constructor name ->
310+ Just (Branch goal (start ++ subPositions path patterns ++ end))
215
311
216− (A.A _ (P.Literal _) : _, _) ->
312+ P.Literal lit | tag == Literal lit ->
217− return []
313+ Just (Branch goal (start ++ end))
218
314
219 _ ->
315 _ ->
220− noMatch "matchClause.getVars"
316+ Nothing
317+
318+ _ ->
319+ Just branch
320+
321+
322+extract
323+ :: Path
324+ -> [(Path, OPattern)]
325+ -> Maybe ([(Path, OPattern)], OPattern, [(Path, OPattern)])
326+extract selectedPath pathPatterns =
327+ case pathPatterns of
328+ [] ->
329+ Nothing
330+
331+ first@(path, pattern) : rest ->
332+ if path == selectedPath then
333+ Just ([], pattern, rest)
334+
335+ else
336+ case extract selectedPath rest of
337+ Nothing ->
338+ Nothing
339+
340+ Just (start, foundPattern, end) ->
341+ Just (first : start, foundPattern, end)
342+
343+
344+-- FIND IRRELEVANT BRANCHES
345+
346+isIrrelevantTo :: Path -> Branch -> Bool
347+isIrrelevantTo selectedPath (Branch _ pathPatterns) =
348+ case List.lookup selectedPath pathPatterns of
349+ Nothing ->
350+ True
351+
352+ Just (A.A _ pattern) ->
353+ case pattern of
354+ P.Var _ ->
355+ True
356+
357+ P.Anything ->
358+ True
359+
360+ P.Alias _ _ ->
361+ error "aliases should never reach 'isIrrelevantTo' function"
362+
363+ P.Record _ ->
364+ True
365+
366+ P.Data _ _ ->
367+ False
368+
369+ P.Literal _ ->
370+ False
221
371
222
372
223−branchEq :: Branch -> Branch -> Bool
373+-- PATH PICKING HEURISTICS
224−branchEq (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
225− case (pattern, pattern') of
226− (P.Data name _, P.Data name' _) ->
227− name == name'
228
374
229− (P.Literal lit, P.Literal lit') ->
375+smallDefaults :: [Branch] -> Path
230− lit == lit'
376+smallDefaults branches =
377+ let
378+ allPaths =
379+ Maybe.mapMaybe isChoicePath (concatMap _patterns branches)
231
380
232− (_, _) ->
381+ weightedPaths =
233− noMatch "matchCon.branchEq"
382+ map (\path -> (path, length (filter (isIrrelevantTo path) branches))) allPaths
383+ in
384+ fst (List.minimumBy (compare `on` snd) weightedPaths)
234
385
235−branchEq _ _ = noMatch "matchCon.branchEq"
236
386
387+isChoicePath :: (Path, OPattern) -> Maybe Path
388+isChoicePath (path, A.A _ pattern) =
389+ case pattern of
390+ P.Var _ ->
391+ Nothing
237
392
238−branchCmp :: Branch -> Branch -> Ordering
393+ P.Anything ->
239−branchCmp (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
394+ Nothing
240− case (pattern, pattern') of
241− (P.Data name _, P.Data name' _) ->
242− compare name name'
243
395
244− (P.Literal lit, P.Literal lit') ->
396+ P.Alias _ _ ->
245− compare lit lit'
397+ error "aliases should never reach 'isChoicePath' function"
246
398
247− (_, _) ->
399+ P.Record _ ->
248− noMatch "matchCon.branchCmp"
400+ Nothing
249
401
250−branchCmp _ _ = noMatch "matchCon.branchCmp"
402+ P.Data _ _ ->
403+ Just path
251
404
405+ P.Literal _ ->
406+ Just path
252
407
253−-- MIX MATCHES
254
408
255−matchMix :: [String] -> [Branch] -> Match -> State Int Match
409+-- smallBranchingFactor :: [Branch] -> Path
256−matchMix vs branches def =
257− State.foldM (flip $ buildMatch vs) def (reverse branchGroups)
258− where
259− branchGroups =
260− List.groupBy (\p1 p2 -> isCon p1 == isCon p2) branches
261
410
262
411
263−noMatch :: String -> a
264−noMatch name =
265− error $ "unexpected pattern in `" ++ name ++
266− "` function. Report a compiler issue to <https://github.com/elm-lang/Elm>."