49032cd · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Clean up code a decent amount

49032cdEvan Czaplicki11 years ago

src/Optimize/Cases.hs+108−104

compare with master

unifiedsplit

@@ -8,14 +8,6 @@ list of patterns and expressions, and then turn that into a "decision tree"

8that requires as few tests as possible to make it to a leaf. Read the paper, it

9explains this extraordinarily well! We are currently using the same heuristics

10as 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-}

11-}

@@ -35,9 +27,18 @@ import qualified Reporting.Annotation as A

36-- COMPILE CASES

28-- COMPILE CASES

30+{-| Users of this module will mainly interact with this function. It takes

31+some normal branches and gives out a decision tree that has "labels" at all

32+the leafs and a dictionary that maps these "labels" to the code that should

33+run.

34+

35+If 2 or more leaves point to the same label, we need to do some tricks in JS to

36+make that work nicely. When is JS getting goto?! ;) That is outside the scope

37+of this module though.

38+-}

38compile

39compile

39 :: VariantDict

40 :: VariantDict

40− -> [(OPattern, Opt.Expr)]

41+ -> [(P.Optimized, Opt.Expr)]

41 -> (DecisionTree Int, Map.Map Int Opt.Expr)

42 -> (DecisionTree Int, Map.Map Int Opt.Expr)

42compile variantDict rawBranches =

43compile variantDict rawBranches =

43 let

44 let

@@ -54,12 +55,29 @@ compile variantDict rawBranches =

54 )

55 )

58+{-| When a certain union type is defined, you specify a certain number of tags.

59+This helps us do a few optimizations:

60+

61+ * If there is only one possible tag, we can always skip checking what it is.

62+ Tuples are a common example of this.

63+ * If we use all possible tags, we can skip doing the last test. If we have

64+ checked N-1 of N tags, there is no need to test the Nth, we know its the

65+ one we want

66+

67+So this dictionary maps tags to the number of variants that exist, so it'll

68+contain things like [ ("Just", 2), ("Nothing", 2), ("_Tuple2", 1), ... ] which

69+we can use for these optimizations.

70+-}

71+type VariantDict =

72+ Map.Map Var.Canonical Int

73+

74+

57-- DECISION TREES

75-- DECISION TREES

59data DecisionTree a

77data DecisionTree a

60− = Test

78+ = Decision

61 { _test :: Path

79 { _test :: Path

62− , _edges :: [(Tag, DecisionTree a)]

80+ , _edges :: [(Test, DecisionTree a)]

63 , _default :: Maybe (DecisionTree a)

81 , _default :: Maybe (DecisionTree a)

64 }

82 }

65 | Match

83 | Match

@@ -68,16 +86,12 @@ data DecisionTree a

68 }

86 }

71−-- EDGE CHECKS

72−

73−data Tag

89+data Test

74 = Constructor Var.Canonical

90 = Constructor Var.Canonical

75 | Literal L.Literal

91 | Literal L.Literal

76 deriving (Eq, Ord)

92 deriving (Eq, Ord)

79−-- PATHS

80−

81data Path

95data Path

82 = Position Int Path

96 = Position Int Path

83 | Field String Path

97 | Field String Path

@@ -86,6 +100,8 @@ data Path

86 deriving (Eq)

100 deriving (Eq)

101

102

103+-- PATH HELPERS

104+

89add :: Path -> Path -> Path

105add :: Path -> Path -> Path

90add path finalLink =

106add path finalLink =

91 case path of

107 case path of

@@ -102,7 +118,7 @@ add path finalLink =

102 Field name (add subpath finalLink)

118 Field name (add subpath finalLink)

103

119

104

120

105−subPositions :: Path -> [OPattern] -> [(Path, OPattern)]

121+subPositions :: Path -> [P.Optimized] -> [(Path, P.Optimized)]

106subPositions path patterns =

122subPositions path patterns =

107 zipWith

123 zipWith

108 (\index pattern -> (add path (Position index Empty), pattern))

124 (\index pattern -> (add path (Position index Empty), pattern))

@@ -110,31 +126,22 @@ subPositions path patterns =

110 patterns

126 patterns

111

127

112

128

113−-- CREATE DECISION TREES

129+-- ACTUALLY BUILD DECISION TREES

114−

115

130

116data Branch =

131data Branch =

117 Branch

132 Branch

118 { _goal :: Int

133 { _goal :: Int

119− , _patterns :: [(Path, OPattern)]

134+ , _patterns :: [(Path, P.Optimized)]

120 }

135 }

121

136

122

137

123−type OPattern = P.Optimized

124−

125−

126−type VariantDict = Map.Map Var.Canonical Int

127−

128−

129−-- BUILD A DECISION TREE

130−

131toDecisionTree :: VariantDict -> [Branch] -> DecisionTree Int

138toDecisionTree :: VariantDict -> [Branch] -> DecisionTree Int

132toDecisionTree variantDict rawBranches =

139toDecisionTree variantDict rawBranches =

133 let

140 let

134 branches =

141 branches =

135− map (skipUselessPatterns variantDict) rawBranches

142+ map (flattenPatterns variantDict) rawBranches

136 in

143 in

137− case isAllValiables branches of

144+ case checkForMatch branches of

138 Just (goal, substitutions) ->

145 Just (goal, substitutions) ->

139 Match goal substitutions

146 Match goal substitutions

140

147

@@ -143,14 +150,14 @@ toDecisionTree variantDict rawBranches =

143 path =

150 path =

144 smallDefaults branches

151 smallDefaults branches

145

152

146− relevantTags =

153+ relevantTests =

147 tagsAtPath path branches

154 tagsAtPath path branches

148

155

149 allRawEdges =

156 allRawEdges =

150− map (edgesFor path branches) relevantTags

157+ map (edgesFor path branches) relevantTests

151

158

152 (rawEdges, unexplored) =

159 (rawEdges, unexplored) =

153− if isComplete variantDict relevantTags then

160+ if isComplete variantDict relevantTests then

154 ( init allRawEdges

161 ( init allRawEdges

155 , snd (last allRawEdges)

162 , snd (last allRawEdges)

156 )

163 )

@@ -168,35 +175,38 @@ toDecisionTree variantDict rawBranches =

168 decisionTree

175 decisionTree

169

176

170 (_, []) ->

177 (_, []) ->

171− Test path edges Nothing

178+ Decision path edges Nothing

172

179

173 (_, _) ->

180 (_, _) ->

174− Test path edges (Just (toDecisionTree variantDict unexplored))

181+ Decision path edges (Just (toDecisionTree variantDict unexplored))

175

182

176

183

177−isComplete :: VariantDict -> [Tag] -> Bool

184+isComplete :: VariantDict -> [Test] -> Bool

178−isComplete variantDict tags =

185+isComplete variantDict tests =

179− case head tags of

186+ case head tests of

180 Constructor name ->

187 Constructor name ->

181− (variantDict ! name) == length tags

188+ (variantDict ! name) == length tests

182

189

183 Literal (L.Boolean _) ->

190 Literal (L.Boolean _) ->

184− length tags == 2

191+ length tests == 2

185

192

186 _ ->

193 _ ->

187 False

194 False

188

195

189

196

190

197

191−-- SKIP USELESS TESTS

198+-- FLATTEN PATTERNS

192

199

200+{-| Flatten type aliases and use the VariantDict to figure out when a tag is

201+the only variant so we can skip doing any tests on it.

202+-}

193−skipUselessPatterns :: VariantDict -> Branch -> Branch

203+flattenPatterns :: VariantDict -> Branch -> Branch

194−skipUselessPatterns variantDict (Branch goal pathPatterns) =

204+flattenPatterns variantDict (Branch goal pathPatterns) =

195− Branch goal (concatMap (skipper variantDict) pathPatterns)

205+ Branch goal (concatMap (flatten variantDict) pathPatterns)

196

206

197

207

198−skipper :: VariantDict -> (Path, OPattern) -> [(Path, OPattern)]

208+flatten :: VariantDict -> (Path, P.Optimized) -> [(Path, P.Optimized)]

199−skipper variantDict pathPattern@(path, A.A ann pattern) =

209+flatten variantDict pathPattern@(path, A.A ann pattern) =

200 case pattern of

210 case pattern of

201 P.Var _ ->

211 P.Var _ ->

202 [pathPattern]

212 [pathPattern]

@@ -214,7 +224,7 @@ skipper variantDict pathPattern@(path, A.A ann pattern) =

214

224

215 P.Data tag patterns ->

225 P.Data tag patterns ->

216 if variantDict ! tag == 1 then

226 if variantDict ! tag == 1 then

217− concatMap (skipper variantDict) (subPositions path patterns)

227+ concatMap (flatten variantDict) (subPositions path patterns)

218

228

219 else

229 else

220 [pathPattern]

230 [pathPattern]

@@ -223,10 +233,15 @@ skipper variantDict pathPattern@(path, A.A ann pattern) =

223 [pathPattern]

233 [pathPattern]

224

234

225

235

226−-- VARIABLE SUBSTITUTIONS

236+-- SUCCESSFULLY MATCH

227

237

238+{-| If the first branch has no more "decision points" we can finally take that

239+path. If that is the case we give the resulting label and a mapping from free

240+variables to "how to get their value". So a pattern like (Just (x,_)) will give

241+us something like ("x" => value.0.0)

242+-}

228−isAllValiables :: [Branch] -> Maybe (Int, Map.Map String Path)

243+checkForMatch :: [Branch] -> Maybe (Int, Map.Map String Path)

229−isAllValiables branches =

244+checkForMatch branches =

230 case branches of

245 case branches of

231 Branch goal patterns : _ ->

246 Branch goal patterns : _ ->

232 do subs <- concat `fmap` mapM getSubstitution patterns

247 do subs <- concat `fmap` mapM getSubstitution patterns

@@ -236,7 +251,7 @@ isAllValiables branches =

236 Nothing

251 Nothing

237

252

238

253

239−getSubstitution :: (Path, OPattern) -> Maybe [(String, Path)]

254+getSubstitution :: (Path, P.Optimized) -> Maybe [(String, Path)]

240getSubstitution (path, A.A _ pattern) =

255getSubstitution (path, A.A _ pattern) =

241 case pattern of

256 case pattern of

242 P.Var x ->

257 P.Var x ->

@@ -258,15 +273,15 @@ getSubstitution (path, A.A _ pattern) =

258 Nothing

273 Nothing

259

274

260

275

261−-- FIND RELEVANT TAGS

276+-- FIND RELEVANT TESTS

262

277

263−tagsAtPath :: Path -> [Branch] -> [Tag]

278+testsAtPath :: Path -> [Branch] -> [Test]

264−tagsAtPath selectedPath branches =

279+testsAtPath selectedPath branches =

265− List.nub $ Maybe.mapMaybe (tagAtPath selectedPath) branches

280+ List.nub $ Maybe.mapMaybe (testAtPath selectedPath) branches

266

281

267

282

268−tagAtPath :: Path -> Branch -> Maybe Tag

283+testAtPath :: Path -> Branch -> Maybe Test

269−tagAtPath selectedPath (Branch _ pathPatterns) =

284+testAtPath selectedPath (Branch _ pathPatterns) =

270 case List.lookup selectedPath pathPatterns of

285 case List.lookup selectedPath pathPatterns of

271 Nothing ->

286 Nothing ->

272 Nothing

287 Nothing

@@ -283,7 +298,7 @@ tagAtPath selectedPath (Branch _ pathPatterns) =

283 Nothing

298 Nothing

284

299

285 P.Alias _ _ ->

300 P.Alias _ _ ->

286− error "aliases should never reach 'tagAtPath' function"

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

287

302

288 P.Anything ->

303 P.Anything ->

289 Nothing

304 Nothing

@@ -294,22 +309,22 @@ tagAtPath selectedPath (Branch _ pathPatterns) =

294

309

295-- BUILD EDGES

310-- BUILD EDGES

296

311

297−edgesFor :: Path -> [Branch] -> Tag -> (Tag, [Branch])

312+edgesFor :: Path -> [Branch] -> Test -> (Test, [Branch])

298−edgesFor path branches tag =

313+edgesFor path branches test =

299− ( tag

314+ ( test

300− , Maybe.mapMaybe (subBranch tag path) branches

315+ , Maybe.mapMaybe (toRelevantBranch test path) branches

301 )

316 )

302

317

303

318

304−subBranch :: Tag -> Path -> Branch -> Maybe Branch

319+toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch

305−subBranch tag path branch@(Branch goal pathPatterns) =

320+toRelevantBranch test path branch@(Branch goal pathPatterns) =

306 case extract path pathPatterns of

321 case extract path pathPatterns of

307 Just (start, A.A _ pattern, end) ->

322 Just (start, A.A _ pattern, end) ->

308 case pattern of

323 case pattern of

309− P.Data name patterns | tag == Constructor name ->

324+ P.Data name patterns | test == Constructor name ->

310 Just (Branch goal (start ++ subPositions path patterns ++ end))

325 Just (Branch goal (start ++ subPositions path patterns ++ end))

311

326

312− P.Literal lit | tag == Literal lit ->

327+ P.Literal lit | test == Literal lit ->

313 Just (Branch goal (start ++ end))

328 Just (Branch goal (start ++ end))

314

329

315 _ ->

330 _ ->

@@ -321,8 +336,8 @@ subBranch tag path branch@(Branch goal pathPatterns) =

321

336

322extract

337extract

323 :: Path

338 :: Path

324− -> [(Path, OPattern)]

339+ -> [(Path, P.Optimized)]

325− -> Maybe ([(Path, OPattern)], OPattern, [(Path, OPattern)])

340+ -> Maybe ([(Path, P.Optimized)], P.Optimized, [(Path, P.Optimized)])

326extract selectedPath pathPatterns =

341extract selectedPath pathPatterns =

327 case pathPatterns of

342 case pathPatterns of

328 [] ->

343 [] ->

@@ -349,25 +364,30 @@ isIrrelevantTo selectedPath (Branch _ pathPatterns) =

349 Nothing ->

364 Nothing ->

350 True

365 True

351

366

367+ Just pattern ->

352− Just (A.A _ pattern) ->

368+ not (needsTests pattern)

353− case pattern of

354− P.Var _ ->

355− True

356

369

357− P.Anything ->

358− True

359

370

360− P.Alias _ _ ->

371+needsTests :: P.Optimized -> Bool

361− error "aliases should never reach 'isIrrelevantTo' function"

372+needsTests (A.A _ pattern) =

373+ case pattern of

374+ P.Var _ ->

375+ False

362

376

363− P.Record _ ->

377+ P.Anything ->

364− True

378+ False

365

379

366− P.Data _ _ ->

380+ P.Alias _ _ ->

367− False

381+ error "aliases should never reach 'isIrrelevantTo' function"

368

382

369− P.Literal _ ->

383+ P.Record _ ->

370− False

384+ False

385+

386+ P.Data _ _ ->

387+ True

388+

389+ P.Literal _ ->

390+ True

371

391

372

392

373-- PATH PICKING HEURISTICS

393-- PATH PICKING HEURISTICS

@@ -384,28 +404,12 @@ smallDefaults branches =

384 fst (List.minimumBy (compare `on` snd) weightedPaths)

404 fst (List.minimumBy (compare `on` snd) weightedPaths)

385

405

386

406

387−isChoicePath :: (Path, OPattern) -> Maybe Path

407+isChoicePath :: (Path, P.Optimized) -> Maybe Path

388−isChoicePath (path, A.A _ pattern) =

408+isChoicePath (path, pattern) =

389− case pattern of

409+ if needsTests pattern then

390− P.Var _ ->

391− Nothing

392−

393− P.Anything ->

394− Nothing

395−

396− P.Alias _ _ ->

397− error "aliases should never reach 'isChoicePath' function"

398−

399− P.Record _ ->

400− Nothing

401−

402− P.Data _ _ ->

403− Just path

410+ Just path

404−

411+ else

405− P.Literal _ ->

412+ Nothing

406− Just path

407

413

408

414

409-- smallBranchingFactor :: [Branch] -> Path

415-- smallBranchingFactor :: [Branch] -> Path

410−

411−