git.iko.soy/elk
on master help sign in
Fix bug in decision tree optimizer
4ac6981Evan Czaplicki
src/Generate/JavaScript/Expression.hs+10
compare with master
unifiedsplit
@@ -893,6 +893,10 @@ generateIfTest mode root (path, test) =
893 JS.Prefix JS.PrefixLNot $
893 JS.Prefix JS.PrefixLNot $
894 JS.Access value (Name.fromLocal "b")
894 JS.Access value (Name.fromLocal "b")
895
895
896+ DT.IsTuple ->
897+ error "COMPILER BUG - there should never be tests on a tuple"
898+
899+
896
900
897generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
901generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
898generateCaseBranch mode label root (test, subTree) =
902generateCaseBranch mode label root (test, subTree) =
@@ -924,6 +928,9 @@ generateCaseValue mode test =
924 DT.IsNil ->
928 DT.IsNil ->
925 error "COMPILER BUG - there should never be three tests on a list"
929 error "COMPILER BUG - there should never be three tests on a list"
926
930
931+ DT.IsTuple ->
932+ error "COMPILER BUG - there should never be three tests on a tuple"
933+
927
934
928generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
935generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr
929generateCaseTest mode root path exampleTest =
936generateCaseTest mode root path exampleTest =
@@ -967,6 +974,9 @@ generateCaseTest mode root path exampleTest =
967 DT.IsNil ->
974 DT.IsNil ->
968 error "COMPILER BUG - there should never be three tests on a list"
975 error "COMPILER BUG - there should never be three tests on a list"
969
976
977+ DT.IsTuple ->
978+ error "COMPILER BUG - there should never be three tests on a list"
979+
970
980
971
981
972-- PATTERN PATHS
982-- PATTERN PATHS
src/Optimize/DecisionTree.hs+120−110
@@ -74,6 +74,7 @@ data Test
74 = IsCtor N.Name Index.ZeroBased Int Can.CtorOpts
74 = IsCtor N.Name Index.ZeroBased Int Can.CtorOpts
75 | IsCons
75 | IsCons
76 | IsNil
76 | IsNil
77+ | IsTuple
77 | IsInt Int
78 | IsInt Int
78 | IsChr Text
79 | IsChr Text
79 | IsStr Text
80 | IsStr Text
@@ -145,8 +146,17 @@ isComplete tests =
145 IsNil ->
146 IsNil ->
146 length tests == 2
147 length tests == 2
147
148
148− _ ->
149+ IsTuple ->
150+ True
151+
152+ IsChr _ ->
153+ False
154+
155+ IsStr _ ->
156+ False
157+
158+ IsInt _ ->
149− False
159+ False
150
160
151
161
152
162
@@ -158,58 +168,63 @@ the only variant so we can skip doing any tests on it.
158-}
168-}
159flattenPatterns :: Branch -> Branch
169flattenPatterns :: Branch -> Branch
160flattenPatterns (Branch goal pathPatterns) =
170flattenPatterns (Branch goal pathPatterns) =
161− Branch goal (concatMap flatten pathPatterns)
171+ Branch goal (foldr flatten [] pathPatterns)
162
172
163
173
164−flatten :: (Path, Can.Pattern) -> [(Path, Can.Pattern)]
174+flatten :: (Path, Can.Pattern) -> [(Path, Can.Pattern)] -> [(Path, Can.Pattern)]
165−flatten pathPattern@(path, A.At region pattern) =
175+flatten pathPattern@(path, A.At region pattern) otherPathPatterns =
166 case pattern of
176 case pattern of
167 Can.PVar _ ->
177 Can.PVar _ ->
168− [pathPattern]
178+ pathPattern : otherPathPatterns
169
179
170 Can.PAnything ->
180 Can.PAnything ->
171− [pathPattern]
181+ pathPattern : otherPathPatterns
172
182
173− Can.PTuple a b Nothing ->
183+ Can.PCtor _ _ (Can.Union _ _ numAlts _) _ _ ctorArgs ->
174− concatMap flatten (subPositions path [a,b])
184+ if numAlts == 1 then
185+ case map dearg ctorArgs of
186+ [arg] ->
187+ flatten (Unbox path, arg) otherPathPatterns
175
188
176− Can.PTuple a b (Just c) ->
189+ args ->
177− concatMap flatten (subPositions path [a,b,c])
190+ foldr flatten otherPathPatterns (subPositions path args)
191+ else
192+ pathPattern : otherPathPatterns
178
193
179− Can.PCtor _ _ (Can.Union _ _ 1 _) _ _ ctorArgs ->
194+ Can.PTuple a b maybeC ->
180− case map dearg ctorArgs of
195+ flatten (Index Index.first path, a) $
181− [arg] ->
196+ flatten (Index Index.second path, b) $
182− flatten (Unbox path, arg)
197+ case maybeC of
198+ Nothing ->
199+ otherPathPatterns
183
200
184− args ->
201+ Just c ->
185− concatMap flatten (subPositions path args)
202+ flatten (Index Index.third path, c) otherPathPatterns
186
203
187− Can.PCtor _ _ _ _ _ _ ->
204+ Can.PUnit ->
188− [pathPattern]
205+ otherPathPatterns
189
206
190 Can.PAlias realPattern alias ->
207 Can.PAlias realPattern alias ->
208+ flatten (path, realPattern) $
191− (path, A.At region (Can.PVar alias)) : flatten (path, realPattern)
209+ (path, A.At region (Can.PVar alias)) : otherPathPatterns
192
210
193 Can.PRecord _ ->
211 Can.PRecord _ ->
194− [pathPattern]
212+ pathPattern : otherPathPatterns
195−
196− Can.PUnit ->
197− [pathPattern]
198
213
199 Can.PList _ ->
214 Can.PList _ ->
200− [pathPattern]
215+ pathPattern : otherPathPatterns
201
216
202 Can.PCons _ _ ->
217 Can.PCons _ _ ->
203− [pathPattern]
218+ pathPattern : otherPathPatterns
204
219
205 Can.PChr _ ->
220 Can.PChr _ ->
206− [pathPattern]
221+ pathPattern : otherPathPatterns
207
222
208 Can.PStr _ ->
223 Can.PStr _ ->
209− [pathPattern]
224+ pathPattern : otherPathPatterns
210
225
211 Can.PInt _ ->
226 Can.PInt _ ->
212− [pathPattern]
227+ pathPattern : otherPathPatterns
213
228
214
229
215subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]
230subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]
@@ -281,55 +296,52 @@ testsAtPath selectedPath branches =
281 , Set.insert test visitedTests
296 , Set.insert test visitedTests
282 )
297 )
283 in
298 in
284− fst (foldr skipVisited ([], Set.empty) allTests)
299+ fst (foldr skipVisited ([], Set.empty) allTests)
285
300
286
301
287testAtPath :: Path -> Branch -> Maybe Test
302testAtPath :: Path -> Branch -> Maybe Test
288testAtPath selectedPath (Branch _ pathPatterns) =
303testAtPath selectedPath (Branch _ pathPatterns) =
289 case List.lookup selectedPath pathPatterns of
304 case List.lookup selectedPath pathPatterns of
290 Nothing ->
305 Nothing ->
291− Nothing
306+ Nothing
292
307
293 Just (A.At _ pattern) ->
308 Just (A.At _ pattern) ->
294− case pattern of
309+ case pattern of
295− Can.PCtor _ _ (Can.Union _ _ numAlts opts) name index _ ->
310+ Can.PCtor _ _ (Can.Union _ _ numAlts opts) name index _ ->
296− Just (IsCtor name index numAlts opts)
311+ Just (IsCtor name index numAlts opts)
297−
298− Can.PInt int ->
299− Just (IsInt int)
300
312
301− Can.PStr str ->
313+ Can.PList ps ->
302− Just (IsStr str)
314+ Just (case ps of { [] -> IsNil ; _ -> IsCons })
303
315
304− Can.PChr chr ->
316+ Can.PCons _ _ ->
305− Just (IsChr chr)
317+ Just IsCons
306
318
307− Can.PList [] ->
319+ Can.PTuple _ _ _ ->
308− Just IsNil
320+ Just IsTuple
309
321
310− Can.PList _ ->
322+ Can.PUnit ->
311− Just IsCons
323+ Just IsTuple
312
324
313− Can.PCons _ _ ->
325+ Can.PVar _ ->
314− Just IsCons
326+ Nothing
315
327
316− Can.PVar _ ->
328+ Can.PAnything ->
317− Nothing
329+ Nothing
318
330
319− Can.PAlias _ _ ->
331+ Can.PInt int ->
320− error "aliases should never reach 'testAtPath' function"
332+ Just (IsInt int)
321
333
322− Can.PAnything ->
334+ Can.PStr str ->
323− Nothing
335+ Just (IsStr str)
324
336
325− Can.PUnit ->
337+ Can.PChr chr ->
326− Nothing
338+ Just (IsChr chr)
327
339
328− Can.PTuple _ _ _ ->
340+ Can.PRecord _ ->
329− Nothing
341+ Nothing
330
342
331− Can.PRecord _ ->
343+ Can.PAlias _ _ ->
332− Nothing
344+ error "aliases should never reach 'testAtPath' function"
333
345
334
346
335
347
@@ -346,7 +358,7 @@ edgesFor path branches test =
346toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch
358toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch
347toRelevantBranch test path branch@(Branch goal pathPatterns) =
359toRelevantBranch test path branch@(Branch goal pathPatterns) =
348 case extract path pathPatterns of
360 case extract path pathPatterns of
349− Just (start, A.At region pattern, end) ->
361+ Found start (A.At region pattern) end ->
350 case pattern of
362 case pattern of
351 Can.PCtor _ _ (Can.Union _ _ numAlts _) name _ ctorArgs ->
363 Can.PCtor _ _ (Can.Union _ _ numAlts _) name _ ctorArgs ->
352 case test of
364 case test of
@@ -410,33 +422,50 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =
410 _ ->
422 _ ->
411 Nothing
423 Nothing
412
424
413− _ ->
425+ Can.PUnit ->
426+ Just (Branch goal (start ++ end))
427+
428+ Can.PTuple a b maybeC ->
429+ Just (Branch goal (start ++ subPositions path (a : b : Maybe.maybeToList maybeC) ++ end))
430+
431+ Can.PVar _ ->
432+ Just branch
433+
434+ Can.PAnything ->
414 Just branch
435 Just branch
415
436
416− _ ->
437+ Can.PRecord _ ->
438+ Just branch
439+
440+ Can.PAlias _ _ ->
441+ Just branch
442+
443+ NotFound ->
417 Just branch
444 Just branch
418
445
419
446
420−extract
447+data Extract
421− :: Path
448+ = NotFound
422− -> [(Path, Can.Pattern)]
449+ | Found [(Path, Can.Pattern)] Can.Pattern [(Path, Can.Pattern)]
423− -> Maybe ([(Path, Can.Pattern)], Can.Pattern, [(Path, Can.Pattern)])
450+
451+
452+extract :: Path -> [(Path, Can.Pattern)] -> Extract
424extract selectedPath pathPatterns =
453extract selectedPath pathPatterns =
425 case pathPatterns of
454 case pathPatterns of
426 [] ->
455 [] ->
427− Nothing
456+ NotFound
428
457
429 first@(path, pattern) : rest ->
458 first@(path, pattern) : rest ->
430 if path == selectedPath then
459 if path == selectedPath then
431− Just ([], pattern, rest)
460+ Found [] pattern rest
432
461
433 else
462 else
434 case extract selectedPath rest of
463 case extract selectedPath rest of
435− Nothing ->
464+ NotFound ->
436− Nothing
465+ NotFound
437
466
438− Just (start, foundPattern, end) ->
467+ Found start foundPattern end ->
439− Just (first : start, foundPattern, end)
468+ Found (first : start) foundPattern end
440
469
441
470
442
471
@@ -456,41 +485,20 @@ isIrrelevantTo selectedPath (Branch _ pathPatterns) =
456needsTests :: Can.Pattern -> Bool
485needsTests :: Can.Pattern -> Bool
457needsTests (A.At _ pattern) =
486needsTests (A.At _ pattern) =
458 case pattern of
487 case pattern of
459− Can.PVar _ ->
488+ Can.PVar _ -> False
460− False
461−
462− Can.PAnything ->
489+ Can.PAnything -> False
463− False
490+ Can.PRecord _ -> False
464−
491+ Can.PCtor _ _ _ _ _ _ -> True
492+ Can.PList _ -> True
493+ Can.PCons _ _ -> True
494+ Can.PUnit -> True
495+ Can.PTuple _ _ _ -> True
496+ Can.PChr _ -> True
497+ Can.PStr _ -> True
498+ Can.PInt _ -> True
465 Can.PAlias _ _ ->
499 Can.PAlias _ _ ->
466 error "aliases should never reach 'isIrrelevantTo' function"
500 error "aliases should never reach 'isIrrelevantTo' function"
467
501
468− Can.PRecord _ ->
469− False
470−
471− Can.PCtor _ _ _ _ _ _ ->
472− True
473−
474− Can.PList _ ->
475− True
476−
477− Can.PCons _ _ ->
478− True
479−
480− Can.PUnit ->
481− False
482−
483− Can.PTuple _ _ _ ->
484− False
485−
486− Can.PChr _ ->
487− True
488−
489− Can.PStr _ ->
490− True
491−
492− Can.PInt _ ->
493− True
494
502
495
503
496
504
@@ -573,9 +581,10 @@ instance Binary Test where
573 IsCtor a b c d -> putWord8 0 >> put a >> put b >> put c >> put d
581 IsCtor a b c d -> putWord8 0 >> put a >> put b >> put c >> put d
574 IsCons -> putWord8 1
582 IsCons -> putWord8 1
575 IsNil -> putWord8 2
583 IsNil -> putWord8 2
584+ IsTuple -> putWord8 3
576− IsChr a -> putWord8 3 >> put a
585+ IsChr a -> putWord8 4 >> put a
577− IsStr a -> putWord8 4 >> put a
586+ IsStr a -> putWord8 5 >> put a
578− IsInt a -> putWord8 5 >> put a
587+ IsInt a -> putWord8 6 >> put a
579
588
580 get =
589 get =
581 do word <- getWord8
590 do word <- getWord8
@@ -583,9 +592,10 @@ instance Binary Test where
583 0 -> liftM4 IsCtor get get get get
592 0 -> liftM4 IsCtor get get get get
584 1 -> pure IsCons
593 1 -> pure IsCons
585 2 -> pure IsNil
594 2 -> pure IsNil
595+ 3 -> pure IsTuple
586− 3 -> liftM IsChr get
596+ 4 -> liftM IsChr get
587− 4 -> liftM IsStr get
597+ 5 -> liftM IsStr get
588− 5 -> liftM IsInt get
598+ 6 -> liftM IsInt get
589 _ -> error "problem getting DecisionTree.Test binary"
599 _ -> error "problem getting DecisionTree.Test binary"
590
600
591
601