81566e2 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Use unique names for all pattern vars, inline when there's only 1 occurrence

81566e2Evan Czaplicki11 years ago

elm-compiler.cabal+1

compare with master

unifiedsplit

@@ -88,6 +88,7 @@ Library

88 Nitpick.TopLevelTypes,

89 Optimize,

90 Optimize.Environment,

91+ Optimize.Inline,

91 Optimize.Patterns,

92 Optimize.Patterns,

92 Optimize.Patterns.DecisionTree,

93 Optimize.Patterns.DecisionTree,

93 Parse.Binop,

94 Parse.Binop,

src/AST/Expression/Optimized.hs+18−6

@@ -1,7 +1,8 @@

1{-# OPTIONS_GHC -Wall #-}

2module AST.Expression.Optimized

3 ( Def(..), Facts(..), dummyFacts

4− , Expr(..), Decision(..)

4+ , Expr(..)

5+ , Decider(..), Choice(..)

5 ) where

6 ) where

7import qualified AST.Expression.General as General

8import qualified AST.Expression.General as General

@@ -19,14 +20,12 @@ import qualified Reporting.Region as R

19data Def

20data Def

20 = Def Facts String Expr

21 = Def Facts String Expr

21 | TailDef Facts String [String] Expr

22 | TailDef Facts String [String] Expr

22− deriving (Eq)

25data Facts = Facts

26 { home :: Maybe ModuleName.Canonical

27 , dependencies :: [Var.TopLevel]

28 }

29− deriving (Eq)

32dummyFacts :: Facts

31dummyFacts :: Facts

@@ -47,7 +46,7 @@ data Expr

47 | TailCall String [String] [Expr]

46 | TailCall String [String] [Expr]

48 | If [(Expr, Expr)] Expr

47 | If [(Expr, Expr)] Expr

49 | Let [Def] Expr

48 | Let [Def] Expr

50− | Case String (DT.DecisionTree Decision) [(Int, Expr)]

49+ | Case String (Decider Choice) [(Int, Expr)]

51 | Data String [Expr]

50 | Data String [Expr]

52 | DataAccess Expr Int

51 | DataAccess Expr Int

53 | Access Expr String

52 | Access Expr String

@@ -56,10 +55,23 @@ data Expr

56 | Port (General.PortImpl Expr Type.Canonical)

55 | Port (General.PortImpl Expr Type.Canonical)

57 | GLShader String String Literal.GLShaderTipe

56 | GLShader String String Literal.GLShaderTipe

58 | Crash R.Region (Maybe String)

57 | Crash R.Region (Maybe String)

58+

59+

60+data Decider a

61+ = Leaf a

62+ | Chain

63+ { _testChain :: [(DT.Path, DT.Test)]

64+ , _success :: Decider a

65+ , _failure :: Decider a

66+ }

67+ | FanOut

68+ { _path :: DT.Path

69+ , _tests :: [(DT.Test, Decider a)]

70+ , _fallback :: Decider a

71+ }

59 deriving (Eq)

72 deriving (Eq)

62−data Decision

75+data Choice

63 = Inline Expr

76 = Inline Expr

64 | Jump Int

77 | Jump Int

65− deriving (Eq)

src/Generate/JavaScript/Expression.hs+54−68

@@ -174,8 +174,8 @@ generateCode expr =

174 If branches finally ->

175 generateIf branches finally

176

177− Case root decisionTree branches ->

177+ Case exprName decider jumps ->

178− JsBlock <$> generateCase root decisionTree branches

178+ JsBlock <$> generateCase exprName decider jumps

179

180 ExplicitList elements ->

181 do jsElements <- mapM generateJsExpr elements

@@ -310,91 +310,75 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

310

311generateCase

312 :: String

313− -> DT.DecisionTree Opt.Decision

313+ -> Opt.Decider Opt.Choice

314 -> [(Int, Opt.Expr)]

315 -> State Int [Statement ()]

316−generateCase root decisionTree jumpBranches =

316+generateCase exprName decider jumps =

317− do decider <- generateDecisionTree root decisionTree

317+ do labelRoot <- Var.fresh

318+ decider <- generateDecider exprName labelRoot decider

318− foldM (goto root) decider jumpBranches

319+ foldM (goto labelRoot) decider jumps

319

320

321

322+-- handle any jumps

323+

321goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]

324goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]

322−goto root decider (target, branch) =

325+goto labelRoot deciderStmts (target, branch) =

323 let

326 let

324− deciderStmt =

327+ labeledDeciderStmt =

325 LabelledStmt ()

328 LabelledStmt ()

326− (targetLabel root target)

329+ (toLabel labelRoot target)

327− (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))

330+ (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))

328 in

331 in

329 do code <- generateCode branch

332 do code <- generateCode branch

330− return (deciderStmt : toStatementList code)

333+ return (labeledDeciderStmt : toStatementList code)

331

334

332

335

333−targetLabel :: String -> Int -> Id ()

336+toLabel :: String -> Int -> Id ()

334−targetLabel root target =

337+toLabel root target =

335 Id () (root ++ "_" ++ show target)

338 Id () (root ++ "_" ++ show target)

336

339

337

340

341+-- turn deciders into ifs and switches

342+

343+generateDecider

344+ :: String

345+ -> String

346+ -> Opt.Decider Opt.Choice

338−generateDecisionTree :: String -> DT.DecisionTree Opt.Decision -> State Int [Statement ()]

347+ -> State Int [Statement ()]

339−generateDecisionTree root decisionTree =

348+generateDecider exprName labelRoot decisionTree =

340 case decisionTree of

349 case decisionTree of

341− DT.Match (Opt.Inline branch) ->

350+ Opt.Leaf (Opt.Inline branch) ->

342 toStatementList <$> generateCode branch

351 toStatementList <$> generateCode branch

343

352

344− DT.Match (Opt.Jump target) ->

353+ Opt.Leaf (Opt.Jump target) ->

345− return [ BreakStmt () (Just (targetLabel root target)) ]

354+ return [ BreakStmt () (Just (toLabel labelRoot target)) ]

346

355

347− DT.Decision testPath [(test, subTree)] (Just fallback) ->

356+ Opt.Chain testChain success failure ->

348 let

357 let

349− (tests, deepestSubTree) =

350− collapseTests [(testPath, test)] fallback subTree

351−

352 makeTest (path, test) =

358 makeTest (path, test) =

353− do testExpr <- pathToTestableExpr root path test

359+ do testExpr <- pathToTestableExpr exprName path test

354 return (InfixExpr () OpStrictEq testExpr (testToExpr test))

360 return (InfixExpr () OpStrictEq testExpr (testToExpr test))

355 in

361 in

356− do testExprs <- mapM makeTest tests

362+ do testExprs <- mapM makeTest testChain

357 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs

363 let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs

358− thenBranch <- generateDecisionTree root deepestSubTree

364+ thenBranch <- generateDecider exprName labelRoot success

359− elseBranch <- generateDecisionTree root fallback

365+ elseBranch <- generateDecider exprName labelRoot failure

360 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]

366 return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]

361

367

362− DT.Decision testPath edges fallback ->

368+ Opt.FanOut path edges fallback ->

363− do testExpr <- pathToTestableExpr root testPath (fst (head edges))

369+ do testExpr <- pathToTestableExpr exprName path (fst (head edges))

364− caseClauses <- mapM (edgeToCaseClause root) edges

370+ caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges

365− caseDefault <- fallbackToDefault root fallback

371+ caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback

366− return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]

372+ return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]

367−

368−

369−collapseTests

370− :: [(DT.Path, DT.Test)]

371− -> DT.DecisionTree Opt.Decision

372− -> DT.DecisionTree Opt.Decision

373− -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Decision)

374−collapseTests tests outerFallback decisionTree =

375− case decisionTree of

376− DT.Decision testPath [(test, subTree)] (Just fallback)

377− | fallback == outerFallback ->

378− collapseTests ((testPath, test) : tests) outerFallback subTree

379

373

380− _ ->

381− (tests, decisionTree)

382−

383−

384−edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Decision) -> State Int (CaseClause ())

385−edgeToCaseClause root (test, subTree) =

386− CaseClause () (testToExpr test) <$> generateDecisionTree root subTree

387−

388−

389−pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())

390−pathToTestableExpr root path exampleTest =

391− do accessExpr <- generateJsExpr (pathToExpr root path)

392− case exampleTest of

393− DT.Constructor _ ->

394− return (DotRef () accessExpr (Id () "ctor"))

395

374

396− DT.Literal _ ->

375+edgeToCaseClause

397− return accessExpr

376+ :: String

377+ -> String

378+ -> (DT.Test, Opt.Decider Opt.Choice)

379+ -> State Int (CaseClause ())

380+edgeToCaseClause exprName labelRoot (test, subTree) =

381+ CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree

398

382

399

383

400testToExpr :: DT.Test -> Expression ()

384testToExpr :: DT.Test -> Expression ()

@@ -410,15 +394,17 @@ testToExpr test =

410 Literal.literal lit

394 Literal.literal lit

411

395

412

396

413−fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Decision) -> State Int [CaseClause ()]

397+-- work with paths

414−fallbackToDefault root fallback =

415− case fallback of

416− Nothing ->

417− return []

418

398

419− Just subTree ->

399+pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())

420− do stmts <- generateDecisionTree root subTree

400+pathToTestableExpr root path exampleTest =

421− return [ CaseDefault () stmts ]

401+ do accessExpr <- generateJsExpr (pathToExpr root path)

402+ case exampleTest of

403+ DT.Constructor _ ->

404+ return (DotRef () accessExpr (Id () "ctor"))

405+

406+ DT.Literal _ ->

407+ return accessExpr

422

408

423

409

424pathToExpr :: String -> DT.Path -> Opt.Expr

410pathToExpr :: String -> DT.Path -> Opt.Expr

src/Optimize.hs+33−7

@@ -1,6 +1,7 @@

1module Optimize (optimize) where

3import qualified Control.Monad as M

4+import qualified Data.Map as Map

4import qualified Data.Traversable as T

5import qualified Data.Traversable as T

6import qualified AST.Expression.General as Expr

7import qualified AST.Expression.General as Expr

@@ -11,6 +12,7 @@ import qualified AST.Module.Name as ModuleName

11import qualified AST.Pattern as P

12import qualified AST.Pattern as P

12import qualified AST.Variable as Var

13import qualified AST.Variable as Var

13import qualified Optimize.Environment as Env

14import qualified Optimize.Environment as Env

15+import qualified Optimize.Inline as Inline

14import qualified Optimize.Patterns as Patterns

16import qualified Optimize.Patterns as Patterns

15import qualified Optimize.Patterns.DecisionTree as DT

17import qualified Optimize.Patterns.DecisionTree as DT

16import qualified Reporting.Annotation as A

18import qualified Reporting.Annotation as A

@@ -138,11 +140,13 @@ patternToDefs home rootName pattern =

138 toDef (name, accessExpr) =

140 toDef (name, accessExpr) =

139 Opt.Def (Opt.Facts home deps) name accessExpr

141 Opt.Def (Opt.Facts home deps) name accessExpr

140 in

142 in

141− map toDef (substitutions rootExpr pattern)

143+ map toDef (patternToSubstitutions rootExpr pattern)

142

144

143

145

146+-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS

147+

144−substitutions :: Opt.Expr -> P.CanonicalPattern -> [(String, Opt.Expr)]

148+patternToSubstitutions :: Opt.Expr -> P.CanonicalPattern -> [(String, Opt.Expr)]

145−substitutions expr (A.A _ pattern) =

149+patternToSubstitutions expr (A.A _ pattern) =

146 case pattern of

150 case pattern of

147 P.Var name ->

151 P.Var name ->

148 [ (name, expr) ]

152 [ (name, expr) ]

@@ -157,10 +161,10 @@ substitutions expr (A.A _ pattern) =

157 []

161 []

158

162

159 P.Alias alias realPattern ->

163 P.Alias alias realPattern ->

160− (alias, expr) : substitutions expr realPattern

164+ (alias, expr) : patternToSubstitutions expr realPattern

161

165

162 P.Data _ patterns ->

166 P.Data _ patterns ->

163− concat (zipWith (substitutions . Opt.DataAccess expr) [0..] patterns)

167+ concat (zipWith (patternToSubstitutions . Opt.DataAccess expr) [0..] patterns)

164

168

165

169

166-- OPTIMIZE EXPRESSIONS

170-- OPTIMIZE EXPRESSIONS

@@ -249,9 +253,12 @@ optimizeExpr context annExpr@(A.A region expression) =

249

253

250 Expr.Case expr branches ->

254 Expr.Case expr branches ->

251 do optExpr <- optimizeExpr Nothing expr

255 do optExpr <- optimizeExpr Nothing expr

252− optBranches <- T.traverse (mapSnd (optimizeExpr context)) branches

253 variantDict <- Env.getVariantDict

256 variantDict <- Env.getVariantDict

257+

258+ name <- Env.freshName

259+ optBranches <- T.traverse (optimizeBranch context name) branches

254− Patterns.optimize variantDict region optExpr optBranches

260+ optCase <- Patterns.optimize variantDict region name optBranches

261+ return $ Opt.Let [ Opt.Def Opt.dummyFacts name optExpr ] optCase

255

262

256 Expr.Data name exprs ->

263 Expr.Data name exprs ->

257 Opt.Data name <$> T.traverse justConvert exprs

264 Opt.Data name <$> T.traverse justConvert exprs

@@ -291,6 +298,25 @@ mapSnd func (x, a) =

291 (,) x <$> func a

298 (,) x <$> func a

292

299

293

300

301+-- OPTIMIZE CASE BRANCHES

302+

303+optimizeBranch

304+ :: Context

305+ -> String

306+ -> (P.CanonicalPattern, Can.Expr)

307+ -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)

308+optimizeBranch context exprName (pattern, canonicalExpr) =

309+ let

310+ root =

311+ Opt.Var (Var.Canonical Var.Local exprName)

312+

313+ substitutions =

314+ Map.fromList (patternToSubstitutions root pattern)

315+ in

316+ do optExpr <- optimizeExpr context canonicalExpr

317+ (,) pattern <$> Inline.inline substitutions optExpr

318+

319+

294-- DETECT TAIL CALL

320-- DETECT TAIL CALL

295

321

296isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])

322isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])

src/Optimize/Inline.hsnew file+291

@@ -0,0 +1,291 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Optimize.Inline (inline) where

4+import Control.Arrow (second, (***))

5+import Control.Monad (foldM)

6+import qualified Data.List as List

7+import qualified Data.Map as Map

9+import AST.Expression.General (PortImpl(..))

10+import AST.Expression.Optimized (Expr(..), Decider(..), Choice(..))

11+import qualified AST.Expression.Optimized as Opt

12+import qualified AST.Variable as Var

13+import qualified Optimize.Environment as Env

14+

15+

16+inline :: Map.Map String Opt.Expr -> Opt.Expr -> Env.Optimizer Opt.Expr

17+inline rawSubs expression =

18+ let

19+ counts =

20+ count expression

21+

22+ annotatedSubs =

23+ Map.toList (Map.intersectionWith (,) counts rawSubs)

24+ in

25+ do (Subs subs defs) <- foldM processSubs (Subs Map.empty []) annotatedSubs

26+ let inlinedExpr = replace subs expression

27+ return $

28+ if null defs then

29+ inlinedExpr

30+

31+ else

32+ Let (map (\(name, expr) -> Opt.Def Opt.dummyFacts name expr) defs) inlinedExpr

33+

34+

35+data Subs = Subs

36+ { _substitutions :: Map.Map String Opt.Expr

37+ , _definitions :: [(String, Opt.Expr)]

38+ }

39+

40+

41+processSubs :: Subs -> (String, (Int, Opt.Expr)) -> Env.Optimizer Subs

42+processSubs (Subs subs defs) (name, (n, expr)) =

43+ if n == 1 then

44+ return $ Subs (Map.insert name expr subs) defs

45+

46+ else

47+ do uniqueName <- Env.freshName

48+ return $ Subs

49+ (Map.insert name (Opt.Var (Var.local uniqueName)) subs)

50+ ((uniqueName, expr) : defs)

51+

52+-- HELPERS

53+

54+deleteBatch :: [String] -> Map.Map String a -> Map.Map String a

55+deleteBatch names dict =

56+ List.foldl' (flip Map.delete) dict names

57+

58+

59+getDefName :: Opt.Def -> String

60+getDefName def =

61+ case def of

62+ Opt.Def _ name _ ->

63+ name

64+

65+ Opt.TailDef _ name _ _ ->

66+ name

67+

68+

69+-- COUNT VARIABLE APPEARANCES

70+

71+count :: Opt.Expr -> Map.Map String Int

72+count expression =

73+ let

74+ count2 a b =

75+ Map.unionWith (+) (count a) (count b)

76+

77+ countMany xs =

78+ Map.unionsWith (+) (map count xs)

79+ in

80+ case expression of

81+ Literal _ ->

82+ Map.empty

83+

84+ Var (Var.Canonical home name) ->

85+ case home of

86+ Var.Local ->

87+ Map.singleton name 1

88+

89+ Var.BuiltIn ->

90+ Map.empty

91+

92+ Var.Module _ ->

93+ Map.empty

94+

95+ Var.TopLevel _ ->

96+ Map.empty

97+

98+ Range lo hi ->

99+ count2 lo hi

100+

101+ ExplicitList exprs ->

102+ countMany exprs

103+

104+ Binop _op left right ->

105+ count2 left right

106+

107+ Function args body ->

108+ deleteBatch args (count body)

109+

110+ Call func args ->

111+ Map.unionWith (+) (count func) (countMany args)

112+

113+ TailCall _name _argNames args ->

114+ countMany args

115+

116+ If branches finally ->

117+ Map.unionsWith (+) (count finally : map (uncurry count2) branches)

118+

119+ Let defs expr ->

120+ let

121+ countDef def =

122+ case def of

123+ Opt.Def _ name body ->

124+ Map.delete name (count body)

125+

126+ Opt.TailDef _ name argNames body ->

127+ deleteBatch (name:argNames) (count body)

128+

129+ exprCount =

130+ deleteBatch (map getDefName defs) (count expr)

131+ in

132+ Map.unionsWith (+) (exprCount : map countDef defs)

133+

134+ Case _ decider jumps ->

135+ let

136+ countDecider dcdr =

137+ case dcdr of

138+ Leaf (Inline expr) ->

139+ count expr

140+

141+ Leaf (Jump _) ->

142+ Map.empty

143+

144+ Chain _ success failure ->

145+ Map.unionWith (+) (countDecider success) (countDecider failure)

146+

147+ FanOut _path tests fallback ->

148+ Map.unionsWith (+) (map countDecider (fallback : map snd tests))

149+ in

150+ Map.unionsWith (+) (countDecider decider : map (count . snd) jumps)

151+

152+ Data _tag values ->

153+ countMany values

154+

155+ DataAccess root _index ->

156+ count root

157+

158+ Access record _field ->

159+ count record

160+

161+ Update record fields ->

162+ Map.unionWith (+) (count record) (countMany (map snd fields))

163+

164+ Record fields ->

165+ countMany (map snd fields)

166+

167+ Port impl ->

168+ case impl of

169+ In _ _ ->

170+ Map.empty

171+

172+ Out _name expr _tipe ->

173+ count expr

174+

175+ Task _name expr _tipe ->

176+ count expr

177+

178+ GLShader _ _ _ ->

179+ Map.empty

180+

181+ Crash _ _ ->

182+ Map.empty

183+

184+

185+-- REPLACE

186+

187+replace :: Map.Map String Opt.Expr -> Opt.Expr -> Opt.Expr

188+replace substitutions expression =

189+ let

190+ go = replace substitutions

191+ in

192+ case expression of

193+ Literal _ ->

194+ expression

195+

196+ Var (Var.Canonical Var.Local name) ->

197+ maybe expression id (Map.lookup name substitutions)

198+

199+ Var _ ->

200+ expression

201+

202+ Range lo hi ->

203+ Range (go lo) (go hi)

204+

205+ ExplicitList exprs ->

206+ ExplicitList (map go exprs)

207+

208+ Binop op left right ->

209+ Binop op (go left) (go right)

210+

211+ Function args body ->

212+ Function args (replace (deleteBatch args substitutions) body)

213+

214+ Call func args ->

215+ Call (go func) (map go args)

216+

217+ TailCall name argNames args ->

218+ TailCall name argNames (map go args)

219+

220+ If branches finally ->

221+ If (map (go *** go) branches) (go finally)

222+

223+ Let defs expr ->

224+ let

225+ replaceDef def =

226+ case def of

227+ Opt.Def facts name body ->

228+ Opt.Def facts name

229+ (replace (Map.delete name substitutions) body)

230+

231+ Opt.TailDef facts name argNames body ->

232+ Opt.TailDef facts name argNames

233+ (replace (deleteBatch (name:argNames) substitutions) body)

234+

235+ boundNames =

236+ map getDefName defs

237+ in

238+ Let

239+ (map replaceDef defs)

240+ (replace (deleteBatch boundNames substitutions) expr)

241+

242+ Case exprName decider jumps ->

243+ let

244+ goDecider dcdr =

245+ case dcdr of

246+ Leaf (Inline expr) ->

247+ Leaf (Inline (go expr))

248+

249+ Leaf (Jump _target) ->

250+ dcdr

251+

252+ Chain chain success failure ->

253+ Chain chain (goDecider success) (goDecider failure)

254+

255+ FanOut path tests fallback ->

256+ FanOut path (map (second goDecider) tests) (goDecider fallback)

257+ in

258+ Case exprName (goDecider decider) (map (second go) jumps)

259+

260+ Data tag values ->

261+ Data tag (map go values)

262+

263+ DataAccess root index ->

264+ DataAccess (go root) index

265+

266+ Access record field ->

267+ Access (go record) field

268+

269+ Update record fields ->

270+ Update (go record) (map (second go) fields)

271+

272+ Record fields ->

273+ Record (map (second go) fields)

274+

275+ Port impl ->

276+ Port $

277+ case impl of

278+ In _ _ ->

279+ impl

280+

281+ Out name expr tipe ->

282+ Out name (go expr) tipe

283+

284+ Task name expr tipe ->

285+ Task name (go expr) tipe

286+

287+ GLShader _ _ _ ->

288+ expression

289+

290+ Crash _ _ ->

291+ expression

src/Optimize/Patterns.hs+152−67

@@ -8,88 +8,166 @@ import qualified Data.Maybe as Maybe

9import qualified AST.Expression.Optimized as Opt

10import qualified AST.Pattern as P

11−import Elm.Utils ((|>))

12import qualified Optimize.Environment as Env

11import qualified Optimize.Environment as Env

13import qualified Optimize.Patterns.DecisionTree as DT

12import qualified Optimize.Patterns.DecisionTree as DT

14import qualified Reporting.Annotation as A

13import qualified Reporting.Annotation as A

15import qualified Reporting.Region as R

14import qualified Reporting.Region as R

17+

18+-- OPTIMIZE A CASE EXPRESSION

19+

20+

18optimize

21optimize

19 :: DT.VariantDict

22 :: DT.VariantDict

20 -> R.Region

23 -> R.Region

21− -> Opt.Expr

24+ -> String

22 -> [(P.CanonicalPattern, Opt.Expr)]

25 -> [(P.CanonicalPattern, Opt.Expr)]

23 -> Env.Optimizer Opt.Expr

26 -> Env.Optimizer Opt.Expr

24−optimize variantDict region optExpr optBranches =

27+optimize variantDict region exprName optBranches =

25− let

26− indexify index (pattern, branch) =

27− ( (pattern, index)

28− , (index, branch)

29− )

30− in

31− do crashBranches <-

28+ do crashBranches <-

32− case last optBranches of

33− (A.A ann P.Anything, Opt.Call (Opt.Crash _ _) [arg]) ->

34− do name <- Env.freshName

35− let newPattern = A.A ann (P.Var name)

36− let newCall = Opt.Call (Opt.Crash region (Just name)) [arg]

37− return (init optBranches ++ [(newPattern, newCall)])

38−

39− _ ->

40− return optBranches

29+ mapM (tagCrashBranches region) optBranches

41−

30+

42− let (patterns, indexedBranches) =

31+ let (patterns, indexedBranches) =

43− unzip (zipWith indexify [0..] crashBranches)

32+ unzip (zipWith indexify [0..] crashBranches)

44−

33+

45− let decisionTree =

34+ let decisionTree =

46− DT.compile variantDict patterns

35+ DT.compile variantDict patterns

47−

36+

37+ return (treeToExpr exprName decisionTree indexedBranches)

38+

39+

40+tagCrashBranches

41+ :: R.Region

42+ -> (P.CanonicalPattern, Opt.Expr)

43+ -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)

44+tagCrashBranches region branch@(pattern@(A.A pr _), expr) =

45+ case expr of

46+ Opt.Call (Opt.Crash _ _) [arg] ->

48− tempName <- Env.freshName

47+ do name <- Env.freshName

49−

48+ return

50− return $

49+ ( A.A pr (P.Alias name pattern)

51− Opt.Let

50+ , Opt.Call (Opt.Crash region (Just name)) [arg]

52− [ Opt.Def Opt.dummyFacts tempName optExpr ]

51+ )

53− (inlinedCase tempName decisionTree indexedBranches)

52+

54−

53+ _ ->

55−

54+ return branch

56−inlinedCase

55+

57− :: String

56+

57+indexify :: Int -> (a,b) -> ((a,Int), (Int,b))

58+indexify index (pattern, branch) =

59+ ( (pattern, index)

60+ , (index, branch)

61+ )

62+

63+

64+

65+-- CONVERT A TREE TO AN EXPRESSION

66+

67+

58− -> DT.DecisionTree Int

68+treeToExpr :: String -> DT.DecisionTree -> [(Int, Opt.Expr)] -> Opt.Expr

59− -> [(Int, Opt.Expr)]

60− -> Opt.Expr

61−inlinedCase name decisionTree jumpTargets =

69+treeToExpr name decisionTree allJumps =

62 let

70 let

71+ decider =

72+ treeToDecider decisionTree

73+

63 targetCounts =

74 targetCounts =

64− countTargets decisionTree

75+ countTargets decider

66− (decisions, sharedBranches) =

77+ (choices, maybeJumps) =

67− unzip (map (toDecisions targetCounts) jumpTargets)

78+ unzip (map (createChoices targetCounts) allJumps)

68 in

79 in

69 Opt.Case

80 Opt.Case

70 name

81 name

71− (inlineDecisions (Map.fromList decisions) decisionTree)

82+ (insertChoices (Map.fromList choices) decider)

72− (Maybe.catMaybes sharedBranches)

83+ (Maybe.catMaybes maybeJumps)

75−countTargets :: DT.DecisionTree Int -> Map.Map Int Int

76−countTargets decisionTree =

77− case decisionTree of

78− DT.Decision _ edges fallback ->

79− map snd edges

80− |> maybe id (:) fallback

81− |> map countTargets

82− |> Map.unionsWith (+)

87+-- TREE TO DECIDER

88+--

89+-- Decision trees may have some redundancies, so we convert them to a Decider

90+-- which has special constructs to avoid code duplication when possible.

91+

92+

93+treeToDecider :: DT.DecisionTree -> Opt.Decider Int

94+treeToDecider tree =

95+ case tree of

84 DT.Match target ->

96 DT.Match target ->

97+ Opt.Leaf target

98+

99+ -- zero options

100+ DT.Decision _ [] Nothing ->

101+ error "compiler bug, somehow created an empty decision tree"

102+

103+ -- one option

104+ DT.Decision _ [(_, subTree)] Nothing ->

105+ treeToDecider subTree

106+

107+ DT.Decision _ [] (Just subTree) ->

108+ treeToDecider subTree

109+

110+ -- two options

111+ DT.Decision path [(test, successTree)] (Just failureTree) ->

112+ toChain path test successTree failureTree

113+

114+ DT.Decision path [(test, successTree), (_, failureTree)] Nothing ->

115+ toChain path test successTree failureTree

116+

117+ -- many options

118+ DT.Decision path edges Nothing ->

119+ let

120+ (necessaryTests, fallback) =

121+ (init edges, snd (last edges))

122+ in

123+ Opt.FanOut

124+ path

125+ (map (second treeToDecider) necessaryTests)

126+ (treeToDecider fallback)

127+

128+ DT.Decision path edges (Just fallback) ->

129+ Opt.FanOut path (map (second treeToDecider) edges) (treeToDecider fallback)

130+

131+

132+toChain :: DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int

133+toChain path test successTree failureTree =

134+ let

135+ failure =

136+ treeToDecider failureTree

137+ in

138+ case treeToDecider successTree of

139+ Opt.Chain testChain success subFailure | failure == subFailure ->

140+ Opt.Chain ((path, test) : testChain) success failure

141+

142+ success ->

143+ Opt.Chain [(path, test)] success failure

144+

145+

146+

147+-- INSERT CHOICES

148+--

149+-- If a target appears exactly once in a Decider, the corresponding expression

150+-- can be inlined. Whether things are inlined or jumps is called a "choice".

151+

152+

153+countTargets :: Opt.Decider Int -> Map.Map Int Int

154+countTargets decisionTree =

155+ case decisionTree of

156+ Opt.Leaf target ->

85 Map.singleton target 1

157 Map.singleton target 1

158

159+ Opt.Chain _ success failure ->

160+ Map.unionWith (+) (countTargets success) (countTargets failure)

161

88−toDecisions

162+ Opt.FanOut _ tests fallback ->

163+ Map.unionsWith (+) (map countTargets (fallback : map snd tests))

164+

165+

166+createChoices

89 :: Map.Map Int Int

167 :: Map.Map Int Int

90 -> (Int, Opt.Expr)

168 -> (Int, Opt.Expr)

91− -> ( (Int, Opt.Decision), Maybe (Int, Opt.Expr) )

169+ -> ( (Int, Opt.Choice), Maybe (Int, Opt.Expr) )

92−toDecisions targetCounts (target, branch) =

170+createChoices targetCounts (target, branch) =

93 if targetCounts ! target == 1 then

171 if targetCounts ! target == 1 then

94 ( (target, Opt.Inline branch)

172 ( (target, Opt.Inline branch)

95 , Nothing

173 , Nothing

@@ -101,18 +179,25 @@ toDecisions targetCounts (target, branch) =

101 )

179 )

102

180

103

181

104−inlineDecisions

182+insertChoices

105− :: Map.Map Int Opt.Decision

183+ :: Map.Map Int Opt.Choice

106− -> DT.DecisionTree Int

184+ -> Opt.Decider Int

107− -> DT.DecisionTree Opt.Decision

185+ -> Opt.Decider Opt.Choice

108−inlineDecisions jumpDict decisionTree =

186+insertChoices choiceDict decider =

109 let

187 let

110 go =

188 go =

111− inlineDecisions jumpDict

189+ insertChoices choiceDict

112 in

190 in

113− case decisionTree of

191+ case decider of

114− DT.Decision test edges fallback ->

192+ Opt.Leaf target ->

193+ Opt.Leaf (choiceDict ! target)

194+

195+ Opt.Chain testChain success failure ->

196+ Opt.Chain testChain (go success) (go failure)

197+

198+ Opt.FanOut path tests fallback ->

115− DT.Decision test (map (second go) edges) (fmap go fallback)

199+ Opt.FanOut path (map (second go) tests) (go fallback)

200+

201+

202+

116

203

117− DT.Match target ->

118− DT.Match (jumpDict ! target)

src/Optimize/Patterns/DecisionTree.hs+7−7

@@ -38,7 +38,7 @@ If 2 or more leaves point to the same label, we need to do some tricks in JS to

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

39of this module though.

40-}

41−compile :: VariantDict -> [(CPattern, Int)] -> DecisionTree Int

41+compile :: VariantDict -> [(CPattern, Int)] -> DecisionTree

42compile variantDict rawBranches =

43 let

44 format (pattern, index) =

@@ -66,12 +66,12 @@ type VariantDict =

67-- DECISION TREES

69−data DecisionTree a

69+data DecisionTree

70− = Match a

70+ = Match Int

71 | Decision

72 { _test :: Path

73− , _edges :: [(Test, DecisionTree a)]

73+ , _edges :: [(Test, DecisionTree)]

74− , _default :: Maybe (DecisionTree a)

74+ , _default :: Maybe DecisionTree

75 }

76 deriving (Eq)

@@ -125,7 +125,7 @@ data Branch =

125 }

126

127

128−toDecisionTree :: VariantDict -> [Branch] -> DecisionTree Int

128+toDecisionTree :: VariantDict -> [Branch] -> DecisionTree

129toDecisionTree variantDict rawBranches =

130 let

131 branches =

@@ -461,4 +461,4 @@ smallBranchingFactor variantDict branches path =

461 (edges, fallback) =

462 gatherEdges variantDict branches path

463 in

464− length edges + (if null fallback then 0 else 1)

464+ length edges + (if null fallback then 0 else 1)