317d3b8 · elk · git.iko.soy

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

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

1{-# OPTIONS_GHC -Wall #-}

2module AST.Expression.Optimized

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

4− , Expr(..), Jump(..), Branch(..)

4+ , Expr(..)

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

5 ) where

6 ) where

6

7

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)

23

24

25data Facts = Facts

26 { home :: Maybe ModuleName.Canonical

27 , dependencies :: [Var.TopLevel]

28 }

29− deriving (Eq)

30

29

31

30

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 Jump) [(Int, Branch)]

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,17 +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)

59− deriving (Eq)

60

58

61

59

62−data Jump

60+data Decider a

63− = Inline Branch

61+ = Leaf a

64− | Jump Int

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

65 deriving (Eq)

72 deriving (Eq)

66

73

67

74

68−data Branch = Branch

75+data Choice

69− { _substitutions :: [(String, DT.Path)]

76+ = Inline Expr

70− , _branch :: Expr

77+ | Jump Int

71− }

72− deriving (Eq)

src/Generate/JavaScript/Expression.hs+57−86

@@ -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.Jump

313+ -> Opt.Decider Opt.Choice

314− -> [(Int, Opt.Branch)]

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+

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

324+goto :: 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 stmts <- generateBranch root branch

332+ do code <- generateCode branch

330− return (deciderStmt : stmts)

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.Jump -> 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− generateBranch root 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.Jump

372− -> DT.DecisionTree Opt.Jump

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

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−

380− _ ->

381− (tests, decisionTree)

382−

383−

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

385−edgeToCaseClause root (test, subTree) =

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

387−

388

373

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,30 +394,17 @@ testToExpr test =

410 Literal.literal lit

394 Literal.literal lit

411

395

412

396

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

397+-- work with paths

414−fallbackToDefault root fallback =

415− case fallback of

416− Nothing ->

417− return []

418−

419− Just subTree ->

420− do stmts <- generateDecisionTree root subTree

421− return [ CaseDefault () stmts ]

422−

423−

424−generateBranch :: String -> Opt.Branch -> State Int [Statement ()]

425−generateBranch root (Opt.Branch substitutions expr) =

426− do substs <- mapM (loadPath root) substitutions

427− let substStmts =

428− if null substs then [] else [ VarDeclStmt () substs ]

429− code <- generateCode expr

430− return (substStmts ++ toStatementList code)

431

398

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

400+pathToTestableExpr root path exampleTest =

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

402+ case exampleTest of

403+ DT.Constructor _ ->

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

432

405

433−loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())

406+ DT.Literal _ ->

434−loadPath root (name, path) =

407+ return accessExpr

435− do jsAccessExpr <- generateJsExpr (pathToExpr root path)

436− return $ varDecl (Var.safe name) jsAccessExpr

437

408

438

409

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

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

src/Optimize.hs+33−7

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

1module Optimize (optimize) where

2

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

5

6

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

3+

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

5+import Control.Monad (foldM)

6+import qualified Data.List as List

7+import qualified Data.Map as Map

8+

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+166−87

@@ -8,117 +8,196 @@ import qualified Data.Maybe as Maybe

8

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

16

15

17

16

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 DT.Jump

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

63− substitutionDict =

71+ decider =

64− gatherSubstitutions decisionTree

72+ treeToDecider decisionTree

73+

74+ targetCounts =

75+ countTargets decider

65

76

66− (jumps, sharedBranches) =

77+ (choices, maybeJumps) =

67− unzip (map (toJumps substitutionDict) jumpTargets)

78+ unzip (map (createChoices targetCounts) allJumps)

68 in

79 in

69 Opt.Case

80 Opt.Case

70 name

81 name

71− (inlineJumps (Map.fromList jumps) decisionTree)

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

72− (Maybe.catMaybes sharedBranches)

83+ (Maybe.catMaybes maybeJumps)

84+

85+

86+

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

96+ DT.Match target ->

97+ Opt.Leaf target

73

98

99+ -- zero options

100+ DT.Decision _ [] Nothing ->

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

74

102

75−gatherSubstitutions

103+ -- one option

76− :: DT.DecisionTree DT.Jump

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

77− -> Map.Map Int [[(String, DT.Path)]]

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

78−gatherSubstitutions decisionTree =

154+countTargets decisionTree =

79 case decisionTree of

155 case decisionTree of

80− DT.Decision _ edges fallback ->

156+ Opt.Leaf target ->

81− map snd edges

157+ Map.singleton target 1

82− |> maybe id (:) fallback

158+

83− |> map gatherSubstitutions

159+ Opt.Chain _ success failure ->

84− |> Map.unionsWith (++)

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

85

161

86− DT.Match (DT.Jump target substitutions) ->

162+ Opt.FanOut _ tests fallback ->

87− Map.singleton target [substitutions]

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

88

164

89

165

90−toJumps

166+createChoices

91− :: Map.Map Int [[(String, DT.Path)]]

167+ :: Map.Map Int Int

92 -> (Int, Opt.Expr)

168 -> (Int, Opt.Expr)

93− -> ( (Int, Opt.Jump), Maybe (Int, Opt.Branch) )

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

94−toJumps substitutionDict (target, branch) =

170+createChoices targetCounts (target, branch) =

95− case substitutionDict ! target of

171+ if targetCounts ! target == 1 then

96− [substitutions] ->

97− ( (target, Opt.Inline (Opt.Branch substitutions branch))

172+ ( (target, Opt.Inline branch)

98− , Nothing

173+ , Nothing

99− )

174+ )

100−

175+

101− substitutions : _ ->

176+ else

102− ( (target, Opt.Jump target)

177+ ( (target, Opt.Jump target)

103− , Just (target, Opt.Branch substitutions branch)

178+ , Just (target, branch)

104− )

179+ )

105−

180+

106− _ ->

181+

107− error "it is not possible for there to be no substitutions"

182+insertChoices

108−

109−

110−inlineJumps

111− :: Map.Map Int Opt.Jump

183+ :: Map.Map Int Opt.Choice

112− -> DT.DecisionTree DT.Jump

184+ -> Opt.Decider Int

113− -> DT.DecisionTree Opt.Jump

185+ -> Opt.Decider Opt.Choice

114−inlineJumps jumpDict decisionTree =

186+insertChoices choiceDict decider =

115 let

187 let

116 go =

188 go =

117− inlineJumps jumpDict

189+ insertChoices choiceDict

118 in

190 in

119− case decisionTree of

191+ case decider of

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

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

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

200+

201+

202+

122

203

123− DT.Match (DT.Jump target _) ->

124− DT.Match (jumpDict ! target)

src/Optimize/Patterns/DecisionTree.hs+12−40

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

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

42compile variantDict rawBranches =

43 let

44 format (pattern, index) =

@@ -66,22 +66,16 @@ type VariantDict =

66

67-- DECISION TREES

68

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)

77

78

79−data Jump = Jump

80− { _result :: Int

81− , _substitutions :: [(String, Path)]

82− }

83−

84−

85data Test

79data Test

86 = Constructor Var.Canonical

80 = Constructor Var.Canonical

87 | Literal L.Literal

81 | Literal L.Literal

@@ -131,15 +125,15 @@ data Branch =

131 }

125 }

132

126

133

127

134−toDecisionTree :: VariantDict -> [Branch] -> DecisionTree Jump

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

135toDecisionTree variantDict rawBranches =

129toDecisionTree variantDict rawBranches =

136 let

130 let

137 branches =

131 branches =

138 map (flattenPatterns variantDict) rawBranches

132 map (flattenPatterns variantDict) rawBranches

139 in

133 in

140 case checkForMatch branches of

134 case checkForMatch branches of

141− Just (goal, substitutions) ->

135+ Just goal ->

142− Match (Jump goal substitutions)

136+ Match goal

143

137

144 Nothing ->

138 Nothing ->

145 let

139 let

@@ -240,38 +234,16 @@ path. If that is the case we give the resulting label and a mapping from free

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

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

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

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

242-}

236-}

243−checkForMatch :: [Branch] -> Maybe (Int, [(String, Path)])

237+checkForMatch :: [Branch] -> Maybe Int

244checkForMatch branches =

238checkForMatch branches =

245 case branches of

239 case branches of

246− Branch goal patterns : _ ->

240+ Branch goal patterns : _ | all (not . needsTests . snd) patterns ->

247− (,) goal `fmap` concat `fmap` mapM getSubstitution patterns

241+ Just goal

248

242

249 _ ->

243 _ ->

250 Nothing

244 Nothing

251

245

252

246

253−getSubstitution :: (Path, CPattern) -> Maybe [(String, Path)]

254−getSubstitution (path, A.A _ pattern) =

255− case pattern of

256− P.Var x ->

257− Just [(x, path)]

258−

259− P.Anything ->

260− Just []

261−

262− P.Alias _ _ ->

263− error "aliases should never reach 'getSubstitution' function"

264−

265− P.Record fields ->

266− Just (map (\name -> (name, add path (Field name Empty))) fields)

267−

268− P.Data _ _ ->

269− Nothing

270−

271− P.Literal _ ->

272− Nothing

273−

274−

275-- GATHER OUTGOING EDGES

247-- GATHER OUTGOING EDGES

276

248

277gatherEdges :: VariantDict -> [Branch] -> Path -> ([(Test, [Branch])], [Branch])

249gatherEdges :: VariantDict -> [Branch] -> Path -> ([(Test, [Branch])], [Branch])

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

489 (edges, fallback) =

461 (edges, fallback) =

490 gatherEdges variantDict branches path

462 gatherEdges variantDict branches path

491 in

463 in

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

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

tests/test-files/good-expected-js/CaseExpression3.elm.js → tests/test-files/good-expected-js/Cases/ListZip.elm.jsrenamed+3−5

@@ -17,11 +17,9 @@ Elm.Main.make = function (_elm) {

17 if (_p0._1.ctor === "Nil") {

18 return Nil;

19 } else {

20− var x = _p0._0._0,

21− xs = _p0._0._1,

22− y = _p0._1._0,

23− ys = _p0._1._1;

24− return A2(Cons,{ctor: "_Tuple2",_0: x,_1: y},A2(zip,xs,ys));

20+ return A2(Cons,

21+ {ctor: "_Tuple2",_0: _p0._0._0,_1: _p0._1._0},

22+ A2(zip,_p0._0._1,_p0._1._1));

25 }

23 }

26 }

24 }

27 });

25 });

tests/test-files/good-expected-js/CodeGenBugs/Shadowing.elm.jsnew file+27

@@ -0,0 +1,27 @@

1+Elm.Main = Elm.Main || {};

2+Elm.Main.make = function (_elm) {

3+ "use strict";

4+ _elm.Main = _elm.Main || {};

5+ if (_elm.Main.values) return _elm.Main.values;

6+ var _U = Elm.Native.Utils.make(_elm);

7+ var _op = {};

8+ var toName = function (a) {

9+ var name = function () {

10+ var _p0 = a;

11+ if (_p0.ctor === "First") {

12+ return "True";

13+ } else {

14+ return _p0._0;

15+ }

16+ }();

17+ return name;

18+ };

19+ var Second = F2(function (a,b) {

20+ return {ctor: "Second",_0: a,_1: b};

21+ });

22+ var First = {ctor: "First"};

23+ return _elm.Main.values = {_op: _op

24+ ,First: First

25+ ,Second: Second

26+ ,toName: toName};

27+};

tests/test-files/good-expected-js/CodeGenBugs/Shadowing2.elm.jsnew file+23

@@ -0,0 +1,23 @@

1+Elm.Main = Elm.Main || {};

2+Elm.Main.make = function (_elm) {

3+ "use strict";

4+ _elm.Main = _elm.Main || {};

5+ if (_elm.Main.values) return _elm.Main.values;

6+ var _U = Elm.Native.Utils.make(_elm);

7+ var _op = {};

8+ var Nothing = {ctor: "Nothing"};

9+ var Just = function (a) { return {ctor: "Just",_0: a};};

10+ var withDefault0 = function (maybe) {

11+ var _p0 = maybe;

12+ if (_p0.ctor === "Just") {

13+ var maybe = Just("shadow argument, but do not overwrite it in JS!");

14+ return _p0._0;

15+ } else {

16+ return 0;

17+ }

18+ };

19+ return _elm.Main.values = {_op: _op

20+ ,Just: Just

21+ ,Nothing: Nothing

22+ ,withDefault0: withDefault0};

23+};

tests/test-files/good-expected-js/TailRecursive.elm.js → tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_ListAny.elm.jsrenamed+6−7

@@ -5,15 +5,14 @@ Elm.Main.make = function (_elm) {

5 if (_elm.Main.values) return _elm.Main.values;

6 var _U = Elm.Native.Utils.make(_elm);

7 var _op = {};

8− var any = F2(function (f,l) {

8+ var any = F2(function (isOk,list) {

9 any: while (true) {

10− var _p0 = l;

10+ var _p0 = list;

11 if (_p0.ctor === "::") {

12− var x = _p0._0,xs = _p0._1;

13− if (f(x)) return true; else {

12+ if (isOk(_p0._0)) return true; else {

14− var _v0 = f,_v1 = xs;

13+ var _v1 = isOk,_v2 = _p0._1;

15− f = _v0;

14+ isOk = _v1;

16− l = _v1;

15+ list = _v2;

17 continue any;

16 continue any;

18 }

17 }

19 } else {

18 } else {

tests/test-files/good-expected-js/NoExpressions.elm.js → tests/test-files/good-expected-js/Declarations/NoDefinitions.elm.jsrenamed

The content is the same.

tests/test-files/good-expected-js/Ports.elm.js → tests/test-files/good-expected-js/Declarations/Ports.elm.jsrenamed

The content is the same.

tests/test-files/good-expected-js/PortsWithTypeAliases.elm.js → tests/test-files/good-expected-js/Declarations/PortsWithTypeAliases.elm.jsrenamed

The content is the same.

tests/test-files/good-expected-js/Otherwise.elm.jsdeleted−13

@@ -1,13 +0,0 @@

1−Elm.Otherwise = Elm.Otherwise || {};

2−Elm.Otherwise.make = function (_elm) {

3− "use strict";

4− _elm.Otherwise = _elm.Otherwise || {};

5− if (_elm.Otherwise.values) return _elm.Otherwise.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var boo = false ? "Yay" : "Boo";

9− var otherwise = 3;

10− return _elm.Otherwise.values = {_op: _op

11− ,otherwise: otherwise

12− ,boo: boo};

13−};

tests/test-files/good-expected-js/AliasSubstitution.elm.js → tests/test-files/good-expected-js/Records/AliasSubstitution.elm.jsrenamed

The content is the same.

tests/test-files/good-expected-js/Unify/NonHomogeneousRecords.elm.js → tests/test-files/good-expected-js/Records/NonHomogeneousRecords.elm.jsrenamed+8−2

@@ -5,7 +5,13 @@ Elm.Main.make = function (_elm) {

5 if (_elm.Main.values) return _elm.Main.values;

6 var _U = Elm.Native.Utils.make(_elm);

7 var _op = {};

8− var f = function (t) { var y = t.y;var x = t.x;return t;};

8+ var bindFields = function (thing) {

9+ var y = thing.y;

10+ var x = thing.x;

11+ return thing;

12+ };

9 var Thing = F2(function (a,b) { return {x: a,y: b};});

13 var Thing = F2(function (a,b) { return {x: a,y: b};});

10− return _elm.Main.values = {_op: _op,Thing: Thing,f: f};

14+ return _elm.Main.values = {_op: _op

15+ ,Thing: Thing

16+ ,bindFields: bindFields};

11};

17};

tests/test-files/good-expected-js/QuotesAndComments.elm.js → tests/test-files/good-expected-js/Strings/QuotesAndComments.elm.jsrenamed

The content is the same.

tests/test-files/good/CaseExpression3.elm → tests/test-files/good/Cases/ListZip.elmrenamed

The content is the same.

tests/test-files/good/CodeGenBugs/Shadowing.elmnew file+22

@@ -0,0 +1,22 @@

1+-- From: https://github.com/elm-lang/elm-compiler/issues/1086

2+--

3+-- Problem is that the `a` in (Second a b) shadowed the argument to `toName`,

4+-- actually overwriting the value.

5+

6+

7+type AType

8+ = First

9+ | Second String String

10+

11+

12+toName : AType -> String

13+toName a =

14+ let name =

15+ case a of

16+ First ->

17+ "True"

18+

19+ Second a b ->

20+ a

21+ in

22+ name

tests/test-files/good/CodeGenBugs/Shadowing2.elmnew file+25

@@ -0,0 +1,25 @@

1+-- https://github.com/elm-lang/elm-compiler/issues/1090

2+--

3+-- The problem was shadowing a variable used in a pattern match, but then

4+-- rebinding the variable before using all the subparts. There was an issue

5+-- in which inlining of certain values let names jump into scopes where they

6+-- did not belong.

7+

8+

9+type Maybe a

10+ = Just a

11+ | Nothing

12+

13+

14+withDefault0 : Maybe Int -> Int

15+withDefault0 maybe =

16+ case maybe of

17+ Just int ->

18+ let

19+ maybe =

20+ Just "shadow argument, but do not overwrite it in JS!"

21+ in

22+ int -- should be from the `maybe` in the argument, not the shadow

23+

24+ _ ->

25+ 0

tests/test-files/good/CodeGenBugs/TailRecursion_ListAny.elmnew file+12

@@ -0,0 +1,12 @@

1+

2+any isOk list =

3+ case list of

4+ first :: rest ->

5+ if isOk first then

6+ True

7+

8+ else

9+ any isOk rest

10+

11+ _ ->

12+ False

tests/test-files/good/NoExpressions.elm → tests/test-files/good/Declarations/NoDefinitions.elmrenamed

The content is the same.

tests/test-files/good/Ports.elm → tests/test-files/good/Declarations/Ports.elmrenamed

The content is the same.

tests/test-files/good/PortsWithTypeAliases.elm → tests/test-files/good/Declarations/PortsWithTypeAliases.elmrenamed

The content is the same.

tests/test-files/good/Otherwise.elmdeleted−5

@@ -1,5 +0,0 @@

1−module Otherwise where

2−

3−otherwise = 3

4−

5−boo = if False then "Yay" else "Boo"

tests/test-files/good/AliasSubstitution.elm → tests/test-files/good/Records/AliasSubstitution.elmrenamed

The content is the same.

tests/test-files/good/Records/NonHomogeneousRecords.elmnew file+14

@@ -0,0 +1,14 @@

1+

2+type alias Thing =

3+ { x : Float

4+ , y : Float

5+ }

6+

7+

8+bindFields : Thing -> Thing

9+bindFields thing =

10+ let

11+ x = thing.x

12+ y = thing.y

13+ in

14+ thing

tests/test-files/good/QuotesAndComments.elm → tests/test-files/good/Strings/QuotesAndComments.elmrenamed

The content is the same.

tests/test-files/good/TailRecursive.elmdeleted−10

@@ -1,10 +0,0 @@

1−

2−any f l =

3− case l of

4− x :: xs ->

5− if f x then

6− True

7− else

8− any f xs

9− _ ->

10− False

tests/test-files/good/Unify/NonHomogeneousRecords.elmdeleted−12

@@ -1,12 +0,0 @@

1−

2−type alias Thing =

3− { x:Float

4− , y:Float

5− }

6−

7−

8−f : Thing -> Thing

9−f t =

10− let x = t.x

11− y = t.y

12− in t