e35986b · elk · git.iko.soy

git.iko.soy/elk

Introduce optimize phase, detect tail calls

This puts this branch in an intermediate state, a bit more work is needed to actually be generating while loops for functions that have tail calls.

commite35986b6a15a33f51d5c8bc1ae19f0916fa5d8d8 authorEvan Czaplicki <info@elm-lang.org> dateThu 23 Jul 2015, 20:17 (11 years ago) parentc67a181

14 files changed+408−88

compare with master

unifiedsplit

elm-compiler.cabal+3 src/AST/Expression/General.hs+1 src/AST/Expression/Optimized.hs+35 src/AST/Module.hs+10−5 src/AST/Pattern.hs+4 src/Canonicalize.hs+4−4 src/Elm/Compiler.hs+7−1 src/Generate/Cases.hs+12−8 src/Generate/JavaScript.hs+65−58 src/Generate/JavaScript/Crash.hs+5−5 src/Generate/Substitute.hs+5−5 src/Optimize.hs+19 src/Optimize/TailCalls.hs+236 src/Reporting/Crash.hs+2−2

elm-compiler.cabal+3

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

4949 AST.Declaration,

5050 AST.Expression.Canonical,

5151 AST.Expression.General,

52+ AST.Expression.Optimized,

5253 AST.Expression.Source,

5354 AST.Expression.Valid,

5455 AST.Helpers,

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

8182 Generate.JavaScript.Variable,

8283 Generate.Substitute,

8384 Nitpick.TopLevelTypes,

85+ Optimize,

86+ Optimize.TailCalls,

8487 Parse.Binop,

8588 Parse.Declaration,

8689 Parse.Expression,

src/AST/Expression/General.hs+1

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

6464 | Crash Crash.Details

6565 deriving (Show)

6666

67+

6768-- PORTS

6869

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

22 ( Interfaces

33 , Types, Aliases, ADTs

44 , AdtInfo, CanonicalAdt

5− , SourceModule, ValidModule, CanonicalModule

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

5+ , SourceModule, ValidModule, CanonicalModule, Optimized

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

77 , Header(..)

88 , Name, nameToString, nameIsNative

99 , Interface(..), toInterface

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

1717

1818import qualified AST.Declaration as Decl

1919import qualified AST.Expression.Canonical as Canonical

20+import qualified AST.Expression.Optimized as Optimized

2021import qualified AST.Type as Type

2122import qualified AST.Variable as Var

2223import qualified Docs.AST as Docs

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

5556

5657

5758type 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)

5964

6065

6166data Module docs imports exports body = Module

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

6873 }

6974

7075

71−data CanonicalBody = CanonicalBody

72− { program :: Canonical.Expr

76+data Body expr = Body

77+ { program :: expr

7378 , types :: Types

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

7580 , aliases :: Aliases

src/AST/Pattern.hs+4

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

3838 Pattern R.Region Var.Canonical

3939

4040

41+type Optimized =

42+ Pattern () Var.Canonical

43+

44+

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

4246list end patterns =

4347 case patterns of

src/Canonicalize.hs+4−4

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

88import qualified Data.Traversable as T

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

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

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

1212

1313import qualified AST.Declaration as D

1414import qualified AST.Expression.General as E

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

6161 Docs.Centralized

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

6363 [Var.Value]

64− Module.CanonicalBody

64+ (Module.Body Canonical.Expr)

6565

6666

6767moduleHelp

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

8989 Setup.environment interfaces modul

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

9191

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

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

9393 body decls =

9494 let nakedDecls = map A.drop decls

9595 in

96− Module.CanonicalBody

96+ Module.Body

9797 { program =

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

9999 in

src/Elm/Compiler.hs+7−1

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

1818import qualified Elm.Compiler.Version as Version

1919import qualified Elm.Docs as Docs

2020import qualified Generate.JavaScript as JS

21+import qualified Optimize

2122import qualified Parse.Module as Parse

2223import qualified Parse.Parse as Parse

2324import qualified Reporting.Annotation as A

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

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

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

8283 docs <- docsGen isExposed modul

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

84+

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)

8490 in

8591 ( maybe dummyDealiaser Dealiaser dealiaser

8692 , map Warning warnings

src/Generate/Cases.hs+12−8

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

88import Data.Maybe (fromMaybe)

1010import qualified AST.Expression.General as Expr

11−import qualified AST.Expression.Canonical as Canonical

11+import qualified AST.Expression.Optimized as Optimized

1212import qualified AST.Literal as Literal

1313import qualified AST.Pattern as P

1414import qualified AST.Variable as Var

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

2222 = Match String [Clause] Match

2323 | Break

2424 | Fail

25− | Other Canonical.Expr

25+ | Other Optimized.Expr

2626 | Seq [Match]

27− deriving Show

27+ deriving (Show)

2828

2929

3030data Clause =

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

32− deriving Show

32+ deriving (Show)

3333

3434

3535type Branch =

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

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

3737

3838

3939-- PUBLIC FUNCTIONS

4040

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

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

4242toMatch patterns =

4343 do v <- newVar

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

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

6161 Seq ms ->

6262 Seq (map (matchSubst pairs) ms)

6363

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

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

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

65+ let

66+ substitutions =

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

68+ in

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

6670

6771 Match n cs m ->

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

src/Generate/JavaScript.hs+65−58

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

1212

1313import AST.Module

1414import AST.Expression.General as Expr

15−import qualified AST.Expression.Canonical as Canonical

15+import qualified AST.Expression.Optimized as Opt

1616import qualified AST.Helpers as Help

1717import AST.Literal

1818import qualified AST.Module as Module

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

2626import qualified Generate.JavaScript.Variable as Var

2727import qualified Reporting.Annotation as A

2828import qualified Reporting.Crash as Crash

29−import qualified Reporting.Region as R

3029

3130

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

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

117116

118117-- EXPRESSIONS

119118

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

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

121120exprToJsExpr canonicalExpr =

122121 toExpr <$> exprToCode canonicalExpr

123122

124123

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

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

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

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

127126 case expr of

128127 Var var ->

129128 jsExpr $ Var.canonical var

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

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

180179

181180 Binop op leftExpr rightExpr ->

182− binop region op leftExpr rightExpr

181+ binop op leftExpr rightExpr

183182

184183 Lambda _ _ ->

185184 generateFunction (Expr.collectLambdas annotatedExpr)

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

207206 generateIf branches finally

208207

209208 Case expr branches ->

210− generateCase region expr branches

209+ generateCase expr branches

211210

212211 ExplicitList elements ->

213212 do jsElements <- mapM exprToJsExpr elements

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

238237 jsExpr (Port.task name expr' portType)

239238

240239 Crash details ->

241− jsExpr $ Crash.crash region details

240+ jsExpr $ Crash.crash details

242241

243242

244243-- FUNCTIONS

245244

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

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

247246generateFunction (args, initialBody) =

248247 do (argVars, patternDefs) <- destructuredArgs args

249248 code <- generateLet patternDefs initialBody

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

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

269268

270269

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

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

272271destructuredArgs args =

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

274273 return (argVars, Maybe.catMaybes maybePatternDefs)

275274

276275

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

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

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

279278 case pat of

280279 P.Var x ->

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

284283 do arg <- Case.newVar

285284 return

286285 ( arg

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

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

288287 )

289288

290289

291290-- LET EXPRESSIONS

292291

293292generateLet

294− :: [Canonical.Def]

295− -> Canonical.Expr

293+ :: [Opt.Def]

294+ -> Opt.Expr

296295 -> State Int Code

297296generateLet givenDefs givenBody =

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

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

308307

309308-- GENERATE IFS

310309

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

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

312311generateIf givenBranches givenFinally =

313312 let

314313 (branches, finally) =

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

334333

335334

336335crushIfs

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

338− -> Canonical.Expr

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

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

337+ -> Opt.Expr

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

340339crushIfs branches finally =

341340 crushIfsHelp [] branches finally

342341

343342

344343crushIfsHelp

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

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

347− -> Canonical.Expr

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

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

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

346+ -> Opt.Expr

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

349348crushIfsHelp visitedBranches unvisitedBranches finally =

350349 case unvisitedBranches of

351350 [] ->

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

369368

370369-- DEFINITIONS

371370

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

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

374− defToStatementsHelp pattern =<< exprToJsExpr expr

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

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

373+ case Opt.tailRecursionDetails facts of

374+ Just (name, arity) ->

375+ error "TODO" name arity

375376

377+ Nothing ->

378+ defToStatementsHelp facts pattern =<< exprToJsExpr expr

376379

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

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

380+

381+defToStatementsHelp

382+ :: Opt.Facts

383+ -> P.Optimized

384+ -> Expression ()

385+ -> State Int [Statement ()]

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

379387 let

380388 define x =

381389 varDecl x jsExpr

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

417425

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

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

420− exception = Crash.crash patternRegion Crash.IncompletePatternMatch

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

421429

422430 _ ->

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

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

425433 where

426434 vars = P.boundVarList annPattern

427− mkVar = A.A patternRegion . localVar

435+ mkVar = A.A () . localVar

428436 toDef y =

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

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

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

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

431439 in

432− defToStatements (Canonical.Definition pat expr Nothing)

440+ defToStatements (Opt.Definition facts pat expr)

433441

434442

435443-- CASE EXPRESSIONS

436444

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

438−generateCase region expr branches =

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

446+generateCase expr branches =

439447 do (tempVar, initialMatch) <-

440448 Case.toMatch branches

441449

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

447455 do expr' <- exprToJsExpr expr

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

449457

450− match' <- match region revisedMatch

458+ match' <- match revisedMatch

451459

452460 jsBlock (stmt ++ match')

453461

454462

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

456−match region mtch =

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

464+match mtch =

457465 case mtch of

458466 Case.Match name clauses mtch' ->

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

460− mtch'' <- match region mtch'

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

468+ mtch'' <- match mtch'

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

462470 where

463471 isLiteral p =

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

480488 expr

481489

482490 Case.Fail ->

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

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

484492

485493 Case.Break ->

486494 return [BreakStmt () Nothing]

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

489497 toStatementList <$> exprToCode expr

490498

491499 Case.Seq ms ->

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

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

493501 where

494502 dropEnd acc [] = acc

495503 dropEnd acc (m:ms) =

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

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

499507

500508

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

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

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

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

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

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

504512 where

505513 vars' =

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

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

517525 string name

518526

519527

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

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

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

522530 case expr of

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

524532 _ -> (defs, lexpr)

525533

526534

527−generate :: Module.CanonicalModule -> String

535+generate :: Module.Optimized -> String

528536generate modul =

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

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

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

613621-- BINARY OPERATORS

614622

615623binop

616− :: R.Region

617− -> Var.Canonical

618− -> Canonical.Expr

619− -> Canonical.Expr

624+ :: Var.Canonical

625+ -> Opt.Expr

626+ -> Opt.Expr

620627 -> State Int Code

621−binop region func left right

628+binop func left right

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

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

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

624631

625632 | func == forwardCompose =

626633 compose (collectLeftAssoc forwardCompose left right)

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

647654 func <| arg

648655

649656

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

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

651658compose functions =

652659 do jsFunctions <- mapM exprToJsExpr functions

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

654661

655662

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

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

657664pipe expressions =

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

659666 jsExpr $ List.foldl' apply value functions

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

740747-- BINARY OPERATOR COLLECTORS

741748

742749-- (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]

744751collectRightAssoc desiredOp left right =

745752 collectRightAssocHelp desiredOp [left] right

746753

747754

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

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

749756collectRightAssocHelp desiredOp exprList expr =

750757 case expr of

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

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

756763

757764

758765-- (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]

760767collectLeftAssoc desiredOp left right =

761768 collectLeftAssocHelp desiredOp [right] left

762769

763770

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

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

765772collectLeftAssocHelp desiredOp exprList expr =

766773 case expr of

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

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

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

1212 "$moduleName"

1313

1414

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

16−crash region details =

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

16+crash details =

1717 case details of

18− Crash.IncompleteMultiIf _ ->

18+ Crash.IncompleteMultiIf region ->

1919 obj ["_U","badIf"]

2020 `call`

2121 [ ref localModuleName

2222 , string (R.toString region)

2323 ]

2424

25− Crash.IncompletePatternMatch ->

25+ Crash.IncompletePatternMatch _region ->

2626 obj ["_U","badCase"]

2727 `call`

2828 [ ref localModuleName

29− , string (R.toString region)

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

3030 ]

3131

3232

src/Generate/Substitute.hs+5−5

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

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

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

7−import qualified AST.Expression.Canonical as Canonical

7+import qualified AST.Expression.Optimized as Optimized

88import qualified AST.Pattern as Pattern

99import qualified AST.Variable as V

1010import Elm.Utils ((|>))

1111import qualified Reporting.Annotation as A

1212

1313

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

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

1515subst old new expression =

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

1717 case expression of

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

4040 then expression

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

4242 where

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

44− Canonical.Definition p (f e) t

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

44+ Optimized.Definition facts pattern (f expr)

4545

4646 anyShadow =

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

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

4848 |> any (Pattern.member old)

4949

5050 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

77data Details

88 = IncompleteMultiIf R.Region

9− | IncompletePatternMatch

9+ | IncompletePatternMatch R.Region

1010 deriving (Show)

1111

1212

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

1616 IncompleteMultiIf _ ->

1717 "incomplete-multi-if"

1818

19− IncompletePatternMatch ->

19+ IncompletePatternMatch _ ->

2020 "incomplete-pattern-match"