4ac6981 · elk · git.iko.soy

git.iko.soy/elk

Fix bug in decision tree optimizer

The problem was that in the old version, the path to an Alias was different than a path to other things. So it’d be (Index 2 Alias) vs (Index 2 Empty) which would avoid collisions with real things that can be matched on. This code fixes this not by adding back the “Alias vs Empty” distinction in paths, but instead by making sure that the alias paths always come after their content. That means you get to the Ctor before you get to the Alias. This change also uses wildcard matches less often. It also fixes some issues with how tuples were handled.

commit4ac69817d71aecd6e8fc9800de0225b1484e9a10 authorEvan Czaplicki <evancz@users.noreply.github.com> dateThu 25 Jan 2018, 20:23 (9 years ago) parentcff909c

2 files changed+130−110

compare with master

unifiedsplit

src/Generate/JavaScript/Expression.hs+10 src/Optimize/DecisionTree.hs+120−110

src/Generate/JavaScript/Expression.hs+10

@@ -893,6 +893,10 @@ generateIfTest mode root (path, test) =

893893 JS.Prefix JS.PrefixLNot $

894894 JS.Access value (Name.fromLocal "b")

895895

896+ DT.IsTuple ->

897+ error "COMPILER BUG - there should never be tests on a tuple"

898+

899+

896900

897901generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case

898902generateCaseBranch mode label root (test, subTree) =

@@ -924,6 +928,9 @@ generateCaseValue mode test =

924928 DT.IsNil ->

925929 error "COMPILER BUG - there should never be three tests on a list"

926930

931+ DT.IsTuple ->

932+ error "COMPILER BUG - there should never be three tests on a tuple"

933+

927934

928935generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr

929936generateCaseTest mode root path exampleTest =

@@ -967,6 +974,9 @@ generateCaseTest mode root path exampleTest =

967974 DT.IsNil ->

968975 error "COMPILER BUG - there should never be three tests on a list"

969976

977+ DT.IsTuple ->

978+ error "COMPILER BUG - there should never be three tests on a list"

979+

970980

971981

972982-- PATTERN PATHS

src/Optimize/DecisionTree.hs+120−110

@@ -74,6 +74,7 @@ data Test

7474 = IsCtor N.Name Index.ZeroBased Int Can.CtorOpts

7575 | IsCons

7676 | IsNil

77+ | IsTuple

7778 | IsInt Int

7879 | IsChr Text

7980 | IsStr Text

@@ -145,8 +146,17 @@ isComplete tests =

145146 IsNil ->

146147 length tests == 2

147148

148− _ ->

149− False

149+ IsTuple ->

150+ True

151+

152+ IsChr _ ->

153+ False

154+

155+ IsStr _ ->

156+ False

157+

158+ IsInt _ ->

159+ False

150160

151161

152162

@@ -158,58 +168,63 @@ the only variant so we can skip doing any tests on it.

158168-}

159169flattenPatterns :: Branch -> Branch

160170flattenPatterns (Branch goal pathPatterns) =

161− Branch goal (concatMap flatten pathPatterns)

171+ Branch goal (foldr flatten [] pathPatterns)

162172

163173

164−flatten :: (Path, Can.Pattern) -> [(Path, Can.Pattern)]

165−flatten pathPattern@(path, A.At region pattern) =

174+flatten :: (Path, Can.Pattern) -> [(Path, Can.Pattern)] -> [(Path, Can.Pattern)]

175+flatten pathPattern@(path, A.At region pattern) otherPathPatterns =

166176 case pattern of

167177 Can.PVar _ ->

168− [pathPattern]

178+ pathPattern : otherPathPatterns

169179

170180 Can.PAnything ->

171− [pathPattern]

181+ pathPattern : otherPathPatterns

172182

173− Can.PTuple a b Nothing ->

174− concatMap flatten (subPositions path [a,b])

183+ Can.PCtor _ _ (Can.Union _ _ numAlts _) _ _ ctorArgs ->

184+ if numAlts == 1 then

185+ case map dearg ctorArgs of

186+ [arg] ->

187+ flatten (Unbox path, arg) otherPathPatterns

175188

176− Can.PTuple a b (Just c) ->

177− concatMap flatten (subPositions path [a,b,c])

189+ args ->

190+ foldr flatten otherPathPatterns (subPositions path args)

191+ else

192+ pathPattern : otherPathPatterns

178193

179− Can.PCtor _ _ (Can.Union _ _ 1 _) _ _ ctorArgs ->

180− case map dearg ctorArgs of

181− [arg] ->

182− flatten (Unbox path, arg)

194+ Can.PTuple a b maybeC ->

195+ flatten (Index Index.first path, a) $

196+ flatten (Index Index.second path, b) $

197+ case maybeC of

198+ Nothing ->

199+ otherPathPatterns

183200

184− args ->

185− concatMap flatten (subPositions path args)

201+ Just c ->

202+ flatten (Index Index.third path, c) otherPathPatterns

186203

187− Can.PCtor _ _ _ _ _ _ ->

188− [pathPattern]

204+ Can.PUnit ->

205+ otherPathPatterns

189206

190207 Can.PAlias realPattern alias ->

191− (path, A.At region (Can.PVar alias)) : flatten (path, realPattern)

208+ flatten (path, realPattern) $

209+ (path, A.At region (Can.PVar alias)) : otherPathPatterns

192210

193211 Can.PRecord _ ->

194− [pathPattern]

195−

196− Can.PUnit ->

197− [pathPattern]

212+ pathPattern : otherPathPatterns

198213

199214 Can.PList _ ->

200− [pathPattern]

215+ pathPattern : otherPathPatterns

201216

202217 Can.PCons _ _ ->

203− [pathPattern]

218+ pathPattern : otherPathPatterns

204219

205220 Can.PChr _ ->

206− [pathPattern]

221+ pathPattern : otherPathPatterns

207222

208223 Can.PStr _ ->

209− [pathPattern]

224+ pathPattern : otherPathPatterns

210225

211226 Can.PInt _ ->

212− [pathPattern]

227+ pathPattern : otherPathPatterns

213228

214229

215230subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]

@@ -281,55 +296,52 @@ testsAtPath selectedPath branches =

281296 , Set.insert test visitedTests

282297 )

283298 in

284− fst (foldr skipVisited ([], Set.empty) allTests)

299+ fst (foldr skipVisited ([], Set.empty) allTests)

285300

286301

287302testAtPath :: Path -> Branch -> Maybe Test

288303testAtPath selectedPath (Branch _ pathPatterns) =

289304 case List.lookup selectedPath pathPatterns of

290305 Nothing ->

291− Nothing

306+ Nothing

292307

293308 Just (A.At _ pattern) ->

294− case pattern of

295− Can.PCtor _ _ (Can.Union _ _ numAlts opts) name index _ ->

296− Just (IsCtor name index numAlts opts)

297−

298− Can.PInt int ->

299− Just (IsInt int)

309+ case pattern of

310+ Can.PCtor _ _ (Can.Union _ _ numAlts opts) name index _ ->

311+ Just (IsCtor name index numAlts opts)

300312

301− Can.PStr str ->

302− Just (IsStr str)

313+ Can.PList ps ->

314+ Just (case ps of { [] -> IsNil ; _ -> IsCons })

303315

304− Can.PChr chr ->

305− Just (IsChr chr)

316+ Can.PCons _ _ ->

317+ Just IsCons

306318

307− Can.PList [] ->

308− Just IsNil

319+ Can.PTuple _ _ _ ->

320+ Just IsTuple

309321

310− Can.PList _ ->

311− Just IsCons

322+ Can.PUnit ->

323+ Just IsTuple

312324

313− Can.PCons _ _ ->

314− Just IsCons

325+ Can.PVar _ ->

326+ Nothing

315327

316− Can.PVar _ ->

317− Nothing

328+ Can.PAnything ->

329+ Nothing

318330

319− Can.PAlias _ _ ->

320− error "aliases should never reach 'testAtPath' function"

331+ Can.PInt int ->

332+ Just (IsInt int)

321333

322− Can.PAnything ->

323− Nothing

334+ Can.PStr str ->

335+ Just (IsStr str)

324336

325− Can.PUnit ->

326− Nothing

337+ Can.PChr chr ->

338+ Just (IsChr chr)

327339

328− Can.PTuple _ _ _ ->

329− Nothing

340+ Can.PRecord _ ->

341+ Nothing

330342

331− Can.PRecord _ ->

332− Nothing

343+ Can.PAlias _ _ ->

344+ error "aliases should never reach 'testAtPath' function"

333345

334346

335347

@@ -346,7 +358,7 @@ edgesFor path branches test =

346358toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch

347359toRelevantBranch test path branch@(Branch goal pathPatterns) =

348360 case extract path pathPatterns of

349− Just (start, A.At region pattern, end) ->

361+ Found start (A.At region pattern) end ->

350362 case pattern of

351363 Can.PCtor _ _ (Can.Union _ _ numAlts _) name _ ctorArgs ->

352364 case test of

@@ -410,33 +422,50 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =

410422 _ ->

411423 Nothing

412424

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 ->

414435 Just branch

415436

416− _ ->

437+ Can.PRecord _ ->

438+ Just branch

439+

440+ Can.PAlias _ _ ->

441+ Just branch

442+

443+ NotFound ->

417444 Just branch

418445

419446

420−extract

421− :: Path

422− -> [(Path, Can.Pattern)]

423− -> Maybe ([(Path, Can.Pattern)], Can.Pattern, [(Path, Can.Pattern)])

447+data Extract

448+ = NotFound

449+ | Found [(Path, Can.Pattern)] Can.Pattern [(Path, Can.Pattern)]

450+

451+

452+extract :: Path -> [(Path, Can.Pattern)] -> Extract

424453extract selectedPath pathPatterns =

425454 case pathPatterns of

426455 [] ->

427− Nothing

456+ NotFound

428457

429458 first@(path, pattern) : rest ->

430459 if path == selectedPath then

431− Just ([], pattern, rest)

460+ Found [] pattern rest

432461

433462 else

434463 case extract selectedPath rest of

435− Nothing ->

436− Nothing

464+ NotFound ->

465+ NotFound

437466

438− Just (start, foundPattern, end) ->

439− Just (first : start, foundPattern, end)

467+ Found start foundPattern end ->

468+ Found (first : start) foundPattern end

440469

441470

442471

@@ -456,41 +485,20 @@ isIrrelevantTo selectedPath (Branch _ pathPatterns) =

456485needsTests :: Can.Pattern -> Bool

457486needsTests (A.At _ pattern) =

458487 case pattern of

459− Can.PVar _ ->

460− False

461−

462− Can.PAnything ->

463− False

464−

488+ Can.PVar _ -> False

489+ Can.PAnything -> False

490+ Can.PRecord _ -> False

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

465499 Can.PAlias _ _ ->

466500 error "aliases should never reach 'isIrrelevantTo' function"

467501

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

494502

495503

496504

@@ -573,9 +581,10 @@ instance Binary Test where

573581 IsCtor a b c d -> putWord8 0 >> put a >> put b >> put c >> put d

574582 IsCons -> putWord8 1

575583 IsNil -> putWord8 2

576− IsChr a -> putWord8 3 >> put a

577− IsStr a -> putWord8 4 >> put a

578− IsInt a -> putWord8 5 >> put a

584+ IsTuple -> putWord8 3

585+ IsChr a -> putWord8 4 >> put a

586+ IsStr a -> putWord8 5 >> put a

587+ IsInt a -> putWord8 6 >> put a

579588

580589 get =

581590 do word <- getWord8

@@ -583,9 +592,10 @@ instance Binary Test where

583592 0 -> liftM4 IsCtor get get get get

584593 1 -> pure IsCons

585594 2 -> pure IsNil

586− 3 -> liftM IsChr get

587− 4 -> liftM IsStr get

588− 5 -> liftM IsInt get

595+ 3 -> pure IsTuple

596+ 4 -> liftM IsChr get

597+ 5 -> liftM IsStr get

598+ 6 -> liftM IsInt get

589599 _ -> error "problem getting DecisionTree.Test binary"

590600

591601