e35986b · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Introduce optimize phase, detect tail calls

e35986bEvan Czaplicki11 years ago

elm-compiler.cabal+3

compare with master

unifiedsplit

@@ -49,6 +49,7 @@ Library

49 AST.Declaration,

50 AST.Expression.Canonical,

51 AST.Expression.General,

52+ AST.Expression.Optimized,

52 AST.Expression.Source,

53 AST.Expression.Source,

53 AST.Expression.Valid,

54 AST.Expression.Valid,

54 AST.Helpers,

55 AST.Helpers,

@@ -81,6 +82,8 @@ Library

81 Generate.JavaScript.Variable,

82 Generate.JavaScript.Variable,

82 Generate.Substitute,

83 Generate.Substitute,

83 Nitpick.TopLevelTypes,

84 Nitpick.TopLevelTypes,

85+ Optimize,

86+ Optimize.TailCalls,

84 Parse.Binop,

87 Parse.Binop,

85 Parse.Declaration,

88 Parse.Declaration,

86 Parse.Expression,

89 Parse.Expression,

src/AST/Expression/General.hs+1

@@ -64,6 +64,7 @@ data Expr' ann def var typ

64 | Crash Crash.Details

65 deriving (Show)

67+

67-- PORTS

68-- PORTS

69data PortImpl expr tipe

70data PortImpl expr tipe

src/AST/Expression/Optimized.hsnew file+35

@@ -0,0 +1,35 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module AST.Expression.Optimized

3+ ( Expr, Expr'

4+ , Def(..)

5+ , Facts(..), dummyFacts

6+ ) where

8+import qualified AST.Expression.General as General

9+import qualified AST.Pattern as Pattern

10+import qualified AST.Type as Type

11+import qualified AST.Variable as Var

12+

13+

14+type Expr =

15+ General.Expr () Def Var.Canonical Type.Canonical

16+

17+

18+type Expr' =

19+ General.Expr' () Def Var.Canonical Type.Canonical

20+

21+

22+data Def

23+ = Definition Facts Pattern.Optimized Expr

24+ deriving (Show)

25+

26+

27+data Facts = Facts

28+ { tailRecursionDetails :: Maybe (String, Int)

29+ }

30+ deriving (Show)

31+

32+

33+dummyFacts :: Facts

34+dummyFacts =

35+ Facts Nothing

src/AST/Module.hs+10−5

@@ -2,8 +2,8 @@ module AST.Module

2 ( Interfaces

3 , Types, Aliases, ADTs

4 , AdtInfo, CanonicalAdt

5− , SourceModule, ValidModule, CanonicalModule

5+ , SourceModule, ValidModule, CanonicalModule, Optimized

6− , Module(..), CanonicalBody(..)

6+ , Module(..), Body(..)

7 , Header(..)

8 , Name, nameToString, nameIsNative

9 , Interface(..), toInterface

@@ -17,6 +17,7 @@ import qualified Data.Map as Map

18import qualified AST.Declaration as Decl

19import qualified AST.Expression.Canonical as Canonical

20+import qualified AST.Expression.Optimized as Optimized

20import qualified AST.Type as Type

21import qualified AST.Type as Type

21import qualified AST.Variable as Var

22import qualified AST.Variable as Var

22import qualified Docs.AST as Docs

23import qualified Docs.AST as Docs

@@ -55,7 +56,11 @@ type ValidModule =

57type CanonicalModule =

58type CanonicalModule =

58− Module Docs.Centralized [Name] [Var.Value] CanonicalBody

59+ Module Docs.Centralized [Name] [Var.Value] (Body Canonical.Expr)

60+

61+

62+type Optimized =

63+ Module Docs.Centralized [Name] [Var.Value] (Body Optimized.Expr)

61data Module docs imports exports body = Module

66data Module docs imports exports body = Module

@@ -68,8 +73,8 @@ data Module docs imports exports body = Module

68 }

73 }

71−data CanonicalBody = CanonicalBody

76+data Body expr = Body

72− { program :: Canonical.Expr

77+ { program :: expr

73 , types :: Types

78 , types :: Types

74 , fixities :: [(Decl.Assoc, Int, String)]

79 , fixities :: [(Decl.Assoc, Int, String)]

75 , aliases :: Aliases

80 , aliases :: Aliases

src/AST/Pattern.hs+4

@@ -38,6 +38,10 @@ type CanonicalPattern =

38 Pattern R.Region Var.Canonical

41+type Optimized =

42+ Pattern () Var.Canonical

43+

44+

41list :: R.Position -> [RawPattern] -> RawPattern

45list :: R.Position -> [RawPattern] -> RawPattern

42list end patterns =

46list end patterns =

43 case patterns of

47 case patterns of

src/Canonicalize.hs+4−4

@@ -8,7 +8,7 @@ import qualified Data.Set as Set

8import qualified Data.Traversable as T

10import AST.Expression.General (Expr'(..), dummyLet)

11−import AST.Module (CanonicalBody(..))

11+import AST.Module (Body(..))

13import qualified AST.Declaration as D

14import qualified AST.Expression.General as E

@@ -61,7 +61,7 @@ type AlmostCanonicalModule =

61 Docs.Centralized

62 ([Module.DefaultImport], [Module.UserImport])

63 [Var.Value]

64− Module.CanonicalBody

64+ (Module.Body Canonical.Expr)

67moduleHelp

@@ -89,11 +89,11 @@ moduleHelp interfaces modul@(Module.Module _ _ comment exports _ decls) =

89 Setup.environment interfaces modul

90 `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls

92− body :: [D.CanonicalDecl] -> Module.CanonicalBody

92+ body :: [D.CanonicalDecl] -> Module.Body Canonical.Expr

93 body decls =

94 let nakedDecls = map A.drop decls

95 in

96− Module.CanonicalBody

96+ Module.Body

97 { program =

98 let expr = Decls.toExpr (Module.names modul) decls

99 in

src/Elm/Compiler.hs+7−1

@@ -18,6 +18,7 @@ import qualified Elm.Compiler.Module as PublicModule

18import qualified Elm.Compiler.Version as Version

19import qualified Elm.Docs as Docs

20import qualified Generate.JavaScript as JS

21+import qualified Optimize

21import qualified Parse.Module as Parse

22import qualified Parse.Module as Parse

22import qualified Parse.Parse as Parse

23import qualified Parse.Parse as Parse

23import qualified Reporting.Annotation as A

24import qualified Reporting.Annotation as A

@@ -80,7 +81,12 @@ compile context source interfaces =

80 (Result.Result (dealiaser, warnings) rawResult) =

81 (Result.Result (dealiaser, warnings) rawResult) =

81 do modul <- Compile.compile user packageName isRoot unwrappedInterfaces source

82 do modul <- Compile.compile user packageName isRoot unwrappedInterfaces source

82 docs <- docsGen isExposed modul

83 docs <- docsGen isExposed modul

84+

83− return (Result docs (Module.toInterface modul) (JS.generate modul))

85+ let interface = Module.toInterface modul

86+ let optModule = Optimize.optimize modul

87+ let javascript = JS.generate optModule

88+

89+ return (Result docs interface javascript)

84 in

90 in

85 ( maybe dummyDealiaser Dealiaser dealiaser

91 ( maybe dummyDealiaser Dealiaser dealiaser

86 , map Warning warnings

92 , map Warning warnings

src/Generate/Cases.hs+12−8

@@ -8,7 +8,7 @@ import qualified Data.List as List

8import Data.Maybe (fromMaybe)

10import qualified AST.Expression.General as Expr

11−import qualified AST.Expression.Canonical as Canonical

11+import qualified AST.Expression.Optimized as Optimized

12import qualified AST.Literal as Literal

13import qualified AST.Pattern as P

14import qualified AST.Variable as Var

@@ -22,23 +22,23 @@ data Match

22 = Match String [Clause] Match

23 | Break

24 | Fail

25− | Other Canonical.Expr

25+ | Other Optimized.Expr

26 | Seq [Match]

27− deriving Show

27+ deriving (Show)

30data Clause =

31 Clause (Either Var.Canonical Literal.Literal) [String] Match

32− deriving Show

32+ deriving (Show)

35type Branch =

36− ([P.CanonicalPattern], Canonical.Expr)

36+ ([P.Optimized], Optimized.Expr)

39-- PUBLIC FUNCTIONS

41−toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

41+toMatch :: [(P.Optimized, Optimized.Expr)] -> State Int (String, Match)

42toMatch patterns =

43 do v <- newVar

44 (,) v <$> buildMatch [v] (map (first (:[])) patterns) Fail

@@ -61,8 +61,12 @@ matchSubst pairs match =

61 Seq ms ->

62 Seq (map (matchSubst pairs) ms)

64− Other (A.A a e) ->

64+ Other (A.A ann expr) ->

65+ let

66+ substitutions =

65− Other . A.A a $ foldr ($) e $ map (\(x,y) -> S.subst x (Expr.localVar y)) pairs

67+ map (\(x,y) -> S.subst x (Expr.localVar y)) pairs

68+ in

69+ Other $ A.A ann $ foldr ($) expr substitutions

67 Match n cs m ->

71 Match n cs m ->

68 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

72 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

src/Generate/JavaScript.hs+65−58

@@ -12,7 +12,7 @@ import Language.ECMAScript3.Syntax

13import AST.Module

14import AST.Expression.General as Expr

15−import qualified AST.Expression.Canonical as Canonical

15+import qualified AST.Expression.Optimized as Opt

16import qualified AST.Helpers as Help

17import AST.Literal

18import qualified AST.Module as Module

@@ -26,7 +26,6 @@ import qualified Generate.JavaScript.Port as Port

26import qualified Generate.JavaScript.Variable as Var

27import qualified Reporting.Annotation as A

28import qualified Reporting.Crash as Crash

29−import qualified Reporting.Region as R

32internalImports :: Module.Name -> [VarDecl ()]

31internalImports :: Module.Name -> [VarDecl ()]

@@ -117,13 +116,13 @@ toExpr code =

117

116

118-- EXPRESSIONS

117-- EXPRESSIONS

119

118

120−exprToJsExpr :: Canonical.Expr -> State Int (Expression ())

119+exprToJsExpr :: Opt.Expr -> State Int (Expression ())

121exprToJsExpr canonicalExpr =

120exprToJsExpr canonicalExpr =

122 toExpr <$> exprToCode canonicalExpr

121 toExpr <$> exprToCode canonicalExpr

123

122

124

123

125−exprToCode :: Canonical.Expr -> State Int Code

124+exprToCode :: Opt.Expr -> State Int Code

126−exprToCode annotatedExpr@(A.A region expr) =

125+exprToCode annotatedExpr@(A.A _ expr) =

127 case expr of

126 case expr of

128 Var var ->

127 Var var ->

129 jsExpr $ Var.canonical var

128 jsExpr $ Var.canonical var

@@ -179,7 +178,7 @@ exprToCode annotatedExpr@(A.A region expr) =

179 map (first prop) (Map.toList (Map.map head fs))

178 map (first prop) (Map.toList (Map.map head fs))

180

179

181 Binop op leftExpr rightExpr ->

180 Binop op leftExpr rightExpr ->

182− binop region op leftExpr rightExpr

181+ binop op leftExpr rightExpr

183

182

184 Lambda _ _ ->

183 Lambda _ _ ->

185 generateFunction (Expr.collectLambdas annotatedExpr)

184 generateFunction (Expr.collectLambdas annotatedExpr)

@@ -207,7 +206,7 @@ exprToCode annotatedExpr@(A.A region expr) =

207 generateIf branches finally

206 generateIf branches finally

208

207

209 Case expr branches ->

208 Case expr branches ->

210− generateCase region expr branches

209+ generateCase expr branches

211

210

212 ExplicitList elements ->

211 ExplicitList elements ->

213 do jsElements <- mapM exprToJsExpr elements

212 do jsElements <- mapM exprToJsExpr elements

@@ -238,12 +237,12 @@ exprToCode annotatedExpr@(A.A region expr) =

238 jsExpr (Port.task name expr' portType)

237 jsExpr (Port.task name expr' portType)

239

238

240 Crash details ->

239 Crash details ->

241− jsExpr $ Crash.crash region details

240+ jsExpr $ Crash.crash details

242

241

243

242

244-- FUNCTIONS

243-- FUNCTIONS

245

244

246−generateFunction :: ([P.CanonicalPattern], Canonical.Expr) -> State Int Code

245+generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code

247generateFunction (args, initialBody) =

246generateFunction (args, initialBody) =

248 do (argVars, patternDefs) <- destructuredArgs args

247 do (argVars, patternDefs) <- destructuredArgs args

249 code <- generateLet patternDefs initialBody

248 code <- generateLet patternDefs initialBody

@@ -268,13 +267,13 @@ generateFunctionWithArity args code =

268 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs

267 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs

269

268

270

269

271−destructuredArgs :: [P.CanonicalPattern] -> State Int ([String], [Canonical.Def])

270+destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])

272destructuredArgs args =

271destructuredArgs args =

273 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args

272 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args

274 return (argVars, Maybe.catMaybes maybePatternDefs)

273 return (argVars, Maybe.catMaybes maybePatternDefs)

275

274

276

275

277−destructPattern :: P.CanonicalPattern -> State Int (String, Maybe Canonical.Def)

276+destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)

278destructPattern pattern@(A.A ann pat) =

277destructPattern pattern@(A.A ann pat) =

279 case pat of

278 case pat of

280 P.Var x ->

279 P.Var x ->

@@ -284,15 +283,15 @@ destructPattern pattern@(A.A ann pat) =

284 do arg <- Case.newVar

283 do arg <- Case.newVar

285 return

284 return

286 ( arg

285 ( arg

287− , Just $ Canonical.Definition pattern (A.A ann (localVar arg)) Nothing

286+ , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))

288 )

287 )

289

288

290

289

291-- LET EXPRESSIONS

290-- LET EXPRESSIONS

292

291

293generateLet

292generateLet

294− :: [Canonical.Def]

293+ :: [Opt.Def]

295− -> Canonical.Expr

294+ -> Opt.Expr

296 -> State Int Code

295 -> State Int Code

297generateLet givenDefs givenBody =

296generateLet givenDefs givenBody =

298 do let (defs, body) = flattenLets givenDefs givenBody

297 do let (defs, body) = flattenLets givenDefs givenBody

@@ -308,7 +307,7 @@ generateLet givenDefs givenBody =

308

307

309-- GENERATE IFS

308-- GENERATE IFS

310

309

311−generateIf :: [(Canonical.Expr, Canonical.Expr)] -> Canonical.Expr -> State Int Code

310+generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code

312generateIf givenBranches givenFinally =

311generateIf givenBranches givenFinally =

313 let

312 let

314 (branches, finally) =

313 (branches, finally) =

@@ -334,18 +333,18 @@ generateIf givenBranches givenFinally =

334

333

335

334

336crushIfs

335crushIfs

337− :: [(Canonical.Expr, Canonical.Expr)]

336+ :: [(Opt.Expr, Opt.Expr)]

338− -> Canonical.Expr

337+ -> Opt.Expr

339− -> ([(Canonical.Expr, Canonical.Expr)], Canonical.Expr)

338+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

340crushIfs branches finally =

339crushIfs branches finally =

341 crushIfsHelp [] branches finally

340 crushIfsHelp [] branches finally

342

341

343

342

344crushIfsHelp

343crushIfsHelp

345− :: [(Canonical.Expr, Canonical.Expr)]

344+ :: [(Opt.Expr, Opt.Expr)]

346− -> [(Canonical.Expr, Canonical.Expr)]

345+ -> [(Opt.Expr, Opt.Expr)]

347− -> Canonical.Expr

346+ -> Opt.Expr

348− -> ([(Canonical.Expr, Canonical.Expr)], Canonical.Expr)

347+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

349crushIfsHelp visitedBranches unvisitedBranches finally =

348crushIfsHelp visitedBranches unvisitedBranches finally =

350 case unvisitedBranches of

349 case unvisitedBranches of

351 [] ->

350 [] ->

@@ -369,13 +368,22 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

369

368

370-- DEFINITIONS

369-- DEFINITIONS

371

370

372−defToStatements :: Canonical.Def -> State Int [Statement ()]

371+defToStatements :: Opt.Def -> State Int [Statement ()]

373−defToStatements (Canonical.Definition pattern expr _) =

372+defToStatements (Opt.Definition facts pattern expr) =

374− defToStatementsHelp pattern =<< exprToJsExpr expr

373+ case Opt.tailRecursionDetails facts of

374+ Just (name, arity) ->

375+ error "TODO" name arity

375

376

377+ Nothing ->

378+ defToStatementsHelp facts pattern =<< exprToJsExpr expr

376

379

380+

377−defToStatementsHelp :: P.CanonicalPattern -> Expression () -> State Int [Statement ()]

381+defToStatementsHelp

382+ :: Opt.Facts

383+ -> P.Optimized

384+ -> Expression ()

385+ -> State Int [Statement ()]

378−defToStatementsHelp annPattern@(A.A patternRegion pattern) jsExpr =

386+defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =

379 let

387 let

380 define x =

388 define x =

381 varDecl x jsExpr

389 varDecl x jsExpr

@@ -417,25 +425,25 @@ defToStatementsHelp annPattern@(A.A patternRegion pattern) jsExpr =

417

425

418 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

426 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

419 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

427 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

420− exception = Crash.crash patternRegion Crash.IncompletePatternMatch

428+ exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))

421

429

422 _ ->

430 _ ->

423 do defs' <- concat <$> mapM toDef vars

431 do defs' <- concat <$> mapM toDef vars

424 return (VarDeclStmt () [define "_"] : defs')

432 return (VarDeclStmt () [define "_"] : defs')

425 where

433 where

426 vars = P.boundVarList annPattern

434 vars = P.boundVarList annPattern

427− mkVar = A.A patternRegion . localVar

435+ mkVar = A.A () . localVar

428 toDef y =

436 toDef y =

429− let expr = A.A patternRegion $ Case (mkVar "_") [(annPattern, mkVar y)]

437+ let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]

430− pat = A.A patternRegion (P.Var y)

438+ pat = A.A () (P.Var y)

431 in

439 in

432− defToStatements (Canonical.Definition pat expr Nothing)

440+ defToStatements (Opt.Definition facts pat expr)

433

441

434

442

435-- CASE EXPRESSIONS

443-- CASE EXPRESSIONS

436

444

437−generateCase :: R.Region -> Canonical.Expr -> [(P.CanonicalPattern, Canonical.Expr)] -> State Int Code

445+generateCase :: Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code

438−generateCase region expr branches =

446+generateCase expr branches =

439 do (tempVar, initialMatch) <-

447 do (tempVar, initialMatch) <-

440 Case.toMatch branches

448 Case.toMatch branches

441

449

@@ -447,17 +455,17 @@ generateCase region expr branches =

447 do expr' <- exprToJsExpr expr

455 do expr' <- exprToJsExpr expr

448 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])

456 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])

449

457

450− match' <- match region revisedMatch

458+ match' <- match revisedMatch

451

459

452 jsBlock (stmt ++ match')

460 jsBlock (stmt ++ match')

453

461

454

462

455−match :: R.Region -> Case.Match -> State Int [Statement ()]

463+match :: Case.Match -> State Int [Statement ()]

456−match region mtch =

464+match mtch =

457 case mtch of

465 case mtch of

458 Case.Match name clauses mtch' ->

466 Case.Match name clauses mtch' ->

459− do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses

467+ do (isChars, clauses') <- unzip <$> mapM (clause name) clauses

460− mtch'' <- match region mtch'

468+ mtch'' <- match mtch'

461 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')

469 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')

462 where

470 where

463 isLiteral p =

471 isLiteral p =

@@ -480,7 +488,7 @@ match region mtch =

480 expr

488 expr

481

489

482 Case.Fail ->

490 Case.Fail ->

483− return [ ExprStmt () (Crash.crash region Crash.IncompletePatternMatch) ]

491+ return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]

484

492

485 Case.Break ->

493 Case.Break ->

486 return [BreakStmt () Nothing]

494 return [BreakStmt () Nothing]

@@ -489,7 +497,7 @@ match region mtch =

489 toStatementList <$> exprToCode expr

497 toStatementList <$> exprToCode expr

490

498

491 Case.Seq ms ->

499 Case.Seq ms ->

492− concat <$> mapM (match region) (dropEnd [] ms)

500+ concat <$> mapM match (dropEnd [] ms)

493 where

501 where

494 dropEnd acc [] = acc

502 dropEnd acc [] = acc

495 dropEnd acc (m:ms) =

503 dropEnd acc (m:ms) =

@@ -498,9 +506,9 @@ match region mtch =

498 _ -> dropEnd (acc ++ [m]) ms

506 _ -> dropEnd (acc ++ [m]) ms

499

507

500

508

501−clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())

509+clause :: String -> Case.Clause -> State Int (Bool, CaseClause ())

502−clause region variable (Case.Clause value vars mtch) =

510+clause variable (Case.Clause value vars mtch) =

503− (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)

511+ (,) isChar . CaseClause () pattern <$> match (Case.matchSubst (zip vars vars') mtch)

504 where

512 where

505 vars' =

513 vars' =

506 map (\n -> variable ++ "._" ++ show n) [0..]

514 map (\n -> variable ++ "._" ++ show n) [0..]

@@ -517,14 +525,14 @@ clause region variable (Case.Clause value vars mtch) =

517 string name

525 string name

518

526

519

527

520−flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

528+flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)

521flattenLets defs lexpr@(A.A _ expr) =

529flattenLets defs lexpr@(A.A _ expr) =

522 case expr of

530 case expr of

523 Let ds body -> flattenLets (defs ++ ds) body

531 Let ds body -> flattenLets (defs ++ ds) body

524 _ -> (defs, lexpr)

532 _ -> (defs, lexpr)

525

533

526

534

527−generate :: Module.CanonicalModule -> String

535+generate :: Module.Optimized -> String

528generate modul =

536generate modul =

529 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

537 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

530 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]

538 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]

@@ -613,14 +621,13 @@ generate modul =

613-- BINARY OPERATORS

621-- BINARY OPERATORS

614

622

615binop

623binop

616− :: R.Region

617− -> Var.Canonical

624+ :: Var.Canonical

618− -> Canonical.Expr

625+ -> Opt.Expr

619− -> Canonical.Expr

626+ -> Opt.Expr

620 -> State Int Code

627 -> State Int Code

621−binop region func left right

628+binop func left right

622 | func == Var.Canonical Var.BuiltIn "::" =

629 | func == Var.Canonical Var.BuiltIn "::" =

623− exprToCode (A.A region (Data "::" [left,right]))

630+ exprToCode (A.A () (Data "::" [left,right]))

624

631

625 | func == forwardCompose =

632 | func == forwardCompose =

626 compose (collectLeftAssoc forwardCompose left right)

633 compose (collectLeftAssoc forwardCompose left right)

@@ -647,13 +654,13 @@ apply arg func =

647 func <| arg

654 func <| arg

648

655

649

656

650−compose :: [Canonical.Expr] -> State Int Code

657+compose :: [Opt.Expr] -> State Int Code

651compose functions =

658compose functions =

652 do jsFunctions <- mapM exprToJsExpr functions

659 do jsFunctions <- mapM exprToJsExpr functions

653 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions

660 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions

654

661

655

662

656−pipe :: [Canonical.Expr] -> State Int Code

663+pipe :: [Opt.Expr] -> State Int Code

657pipe expressions =

664pipe expressions =

658 do (value:functions) <- mapM exprToJsExpr expressions

665 do (value:functions) <- mapM exprToJsExpr expressions

659 jsExpr $ List.foldl' apply value functions

666 jsExpr $ List.foldl' apply value functions

@@ -740,12 +747,12 @@ cmp op n a b =

740-- BINARY OPERATOR COLLECTORS

747-- BINARY OPERATOR COLLECTORS

741

748

742-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff

749-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff

743−collectRightAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]

750+collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

744collectRightAssoc desiredOp left right =

751collectRightAssoc desiredOp left right =

745 collectRightAssocHelp desiredOp [left] right

752 collectRightAssocHelp desiredOp [left] right

746

753

747

754

748−collectRightAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]

755+collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

749collectRightAssocHelp desiredOp exprList expr =

756collectRightAssocHelp desiredOp exprList expr =

750 case expr of

757 case expr of

751 A.A _ (Binop op left right) | op == desiredOp ->

758 A.A _ (Binop op left right) | op == desiredOp ->

@@ -756,12 +763,12 @@ collectRightAssocHelp desiredOp exprList expr =

756

763

757

764

758-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff

765-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff

759−collectLeftAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]

766+collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

760collectLeftAssoc desiredOp left right =

767collectLeftAssoc desiredOp left right =

761 collectLeftAssocHelp desiredOp [right] left

768 collectLeftAssocHelp desiredOp [right] left

762

769

763

770

764−collectLeftAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]

771+collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

765collectLeftAssocHelp desiredOp exprList expr =

772collectLeftAssocHelp desiredOp exprList expr =

766 case expr of

773 case expr of

767 A.A _ (Binop op left right) | op == desiredOp ->

774 A.A _ (Binop op left right) | op == desiredOp ->

src/Generate/JavaScript/Crash.hs+5−5

@@ -12,21 +12,21 @@ localModuleName =

12 "$moduleName"

15−crash :: R.Region -> Crash.Details -> Expression ()

15+crash :: Crash.Details -> Expression ()

16−crash region details =

16+crash details =

17 case details of

18− Crash.IncompleteMultiIf _ ->

18+ Crash.IncompleteMultiIf region ->

19 obj ["_U","badIf"]

20 `call`

21 [ ref localModuleName

22 , string (R.toString region)

23 ]

25− Crash.IncompletePatternMatch ->

25+ Crash.IncompletePatternMatch _region ->

26 obj ["_U","badCase"]

27 `call`

28 [ ref localModuleName

29− , string (R.toString region)

29+ , string "bugs in reporting the exact location right now" -- TODO

30 ]

src/Generate/Substitute.hs+5−5

@@ -4,14 +4,14 @@ module Generate.Substitute (subst) where

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

6import AST.Expression.General (Expr'(..), PortImpl(..))

7−import qualified AST.Expression.Canonical as Canonical

7+import qualified AST.Expression.Optimized as Optimized

8import qualified AST.Pattern as Pattern

9import qualified AST.Variable as V

10import Elm.Utils ((|>))

11import qualified Reporting.Annotation as A

14−subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

14+subst :: String -> Optimized.Expr' -> Optimized.Expr' -> Optimized.Expr'

15subst old new expression =

16 let f (A.A a e) = A.A a (subst old new e) in

17 case expression of

@@ -40,11 +40,11 @@ subst old new expression =

40 then expression

41 else Let (map substDef defs) (f body)

42 where

43− substDef (Canonical.Definition p e t) =

43+ substDef (Optimized.Definition facts pattern expr) =

44− Canonical.Definition p (f e) t

44+ Optimized.Definition facts pattern (f expr)

46 anyShadow =

47− map (\(Canonical.Definition p _ _) -> p) defs

47+ map (\(Optimized.Definition _ p _) -> p) defs

48 |> any (Pattern.member old)

50 Var (V.Canonical home x) ->

src/Optimize.hsnew file+19

@@ -0,0 +1,19 @@

1+module Optimize where

3+import qualified AST.Module as M

4+import qualified Optimize.TailCalls as TC

7+optimize :: M.CanonicalModule -> M.Optimized

8+optimize modul =

9+ let

10+ canonicalBody =

11+ M.body modul

12+

13+ optimizedProgram =

14+ TC.optimize (M.program canonicalBody)

15+

16+ optimizedBody =

17+ canonicalBody { M.program = optimizedProgram }

18+ in

19+ modul { M.body = optimizedBody }

src/Optimize/TailCalls.hsnew file+236

@@ -0,0 +1,236 @@

1+module Optimize.TailCalls where

3+import Control.Applicative

4+import Control.Arrow (first)

5+import qualified Control.Monad as M

6+import qualified Data.List as List

7+import qualified Data.Traversable as T

9+import AST.Expression.General as Expr

10+import qualified AST.Expression.Canonical as Can

11+import qualified AST.Expression.Optimized as Opt

12+import qualified AST.Pattern as P

13+import qualified AST.Variable as Var

14+import qualified Reporting.Annotation as A

15+

16+

17+-- OPTIMIZE FOR TAIL CALLS

18+

19+optimize :: Can.Expr -> Opt.Expr

20+optimize expression =

21+ let

22+ (Result _ optExpr) =

23+ findTailCalls Nothing expression

24+ in

25+ optExpr

26+

27+

28+-- TRACKER TO THREAD FINDINGS THROUGH TRAVERSAL

29+

30+data Result a = Result Bool a

31+

32+

33+instance M.Functor Result where

34+ fmap func (Result hasTailCall value) =

35+ Result hasTailCall (func value)

36+

37+

38+instance Applicative Result where

39+ pure value =

40+ Result False value

41+

42+ (<*>) (Result hasTailCall func) (Result hasTailCall' value) =

43+ Result (hasTailCall || hasTailCall') (func value)

44+

45+

46+mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)

47+mapSnd func (x, a) =

48+ (,) x <$> func a

49+

50+

51+-- CONVERT DEFINITIONS

52+

53+detectTailRecursion :: Can.Def -> Opt.Def

54+detectTailRecursion (Can.Definition pattern expression _) =

55+ let

56+ (args, body) =

57+ Expr.collectLambdas expression

58+

59+ context :: Context

60+ context =

61+ case (pattern, args) of

62+ -- detect if it is a function

63+ (A.A _ (P.Var name), _ : _) ->

64+ Just (name, length args)

65+

66+ _ ->

67+ Nothing

68+

69+ (Result isTailCall optExpr) =

70+ findTailCalls context body

71+ in

72+ Opt.Definition

73+ (Opt.Facts (if isTailCall then context else Nothing))

74+ (removeAnnotations pattern)

75+ optExpr

76+

77+

78+-- CONVERT EXPRESSIONS

79+

80+type Context = Maybe (String, Int)

81+

82+

83+findTailCalls :: Context -> Can.Expr -> Result Opt.Expr

84+findTailCalls context annExpr@(A.A _ expression) =

85+ let

86+ keepLooking =

87+ findTailCalls context

88+ -- this *might* find a tail call, use this when something is a potential

89+ -- tail call

90+

91+ justConvert =

92+ findTailCalls Nothing

93+ -- this will never find tail calls, use this when you are working with

94+ -- expressions that cannot be turned into tail calls

95+ in

96+ A.A () <$>

97+ case expression of

98+ Literal lit ->

99+ pure (Literal lit)

100+

101+ Var name ->

102+ pure (Var name)

103+

104+ Range lowExpr highExpr ->

105+ Range

106+ <$> justConvert lowExpr

107+ <*> justConvert highExpr

108+

109+ ExplicitList elements ->

110+ ExplicitList

111+ <$> T.traverse justConvert elements

112+

113+ Binop op leftExpr rightExpr ->

114+ Binop op

115+ <$> justConvert leftExpr

116+ <*> justConvert rightExpr

117+

118+ Lambda pattern body ->

119+ Lambda (removeAnnotations pattern) <$> justConvert body

120+

121+ App _ _ ->

122+ let

123+ (func:args) =

124+ Expr.collectApps annExpr

125+

126+ isTailCall =

127+ case (context, func) of

128+ ( Just (name, argNum), A.A _ (Var (Var.Canonical Var.Local name')) ) ->

129+ name == name' && length args == argNum

130+ _ ->

131+ False

132+

133+ (Result _ (A.A _ optFunc)) =

134+ justConvert func

135+

136+ (Result _ optArgs) =

137+ T.traverse justConvert args

138+

139+ apply f arg =

140+ App (A.A () f) arg

141+ in

142+ Result isTailCall (List.foldl' apply optFunc optArgs)

143+

144+

145+ MultiIf branches finally ->

146+ let

147+ crawlBranch (cond,branch) =

148+ (,) <$> justConvert cond <*> keepLooking branch

149+ in

150+ MultiIf

151+ <$> T.traverse crawlBranch branches

152+ <*> keepLooking finally

153+

154+ Let defs body ->

155+ let

156+ optDefs = map detectTailRecursion defs

157+ in

158+ Let optDefs <$> keepLooking body

159+

160+ Case expr cases ->

161+ let

162+ preppedCases =

163+ map (first removeAnnotations) cases

164+ in

165+ Case

166+ <$> justConvert expr

167+ <*> T.traverse (mapSnd keepLooking) preppedCases

168+

169+ Data name exprs ->

170+ Data name <$> T.traverse justConvert exprs

171+

172+ Access record field ->

173+ Access

174+ <$> justConvert record

175+ <*> pure field

176+

177+ Remove record field ->

178+ Remove

179+ <$> justConvert record

180+ <*> pure field

181+

182+ Insert record field expr ->

183+ Insert

184+ <$> justConvert record

185+ <*> pure field

186+ <*> justConvert expr

187+

188+ Modify record fields ->

189+ Modify

190+ <$> justConvert record

191+ <*> T.traverse (mapSnd justConvert) fields

192+

193+ Record fields ->

194+ Record

195+ <$> T.traverse (mapSnd justConvert) fields

196+

197+ GLShader uid src gltipe ->

198+ pure (GLShader uid src gltipe)

199+

200+ Port impl ->

201+ Port <$>

202+ case impl of

203+ In name tipe ->

204+ pure (In name tipe)

205+

206+ Out name expr tipe ->

207+ (\e -> Out name e tipe) <$> justConvert expr

208+

209+ Task name expr tipe ->

210+ (\e -> Task name e tipe) <$> justConvert expr

211+

212+ Crash details ->

213+ pure (Crash details)

214+

215+

216+removeAnnotations :: P.CanonicalPattern -> P.Optimized

217+removeAnnotations (A.A _ pattern) =

218+ A.A () $

219+ case pattern of

220+ P.Var x ->

221+ P.Var x

222+

223+ P.Literal lit ->

224+ P.Literal lit

225+

226+ P.Record fields ->

227+ P.Record fields

228+

229+ P.Anything ->

230+ P.Anything

231+

232+ P.Alias alias realPattern ->

233+ P.Alias alias (removeAnnotations realPattern)

234+

235+ P.Data name patterns ->

236+ P.Data name (map removeAnnotations patterns)

src/Reporting/Crash.hs+2−2

@@ -6,7 +6,7 @@ import qualified Reporting.Region as R

7data Details

8 = IncompleteMultiIf R.Region

9− | IncompletePatternMatch

9+ | IncompletePatternMatch R.Region

10 deriving (Show)

@@ -16,5 +16,5 @@ summary details =

16 IncompleteMultiIf _ ->

17 "incomplete-multi-if"

19− IncompletePatternMatch ->

19+ IncompletePatternMatch _ ->

20 "incomplete-pattern-match"