ef92a1d · elk · git.iko.soy

git.iko.soy/elk

Merge branch 'case-compiler'

commitef92a1d38436ccc4d10d2fe24723febbe330114d authorEvan Czaplicki <info@elm-lang.org> dateSun 6 Sep 2015, 01:20 (11 years ago) parent723bccd 3f6dcdb

22 files changed+1392−1032

compare with master

unifiedsplit

elm-compiler.cabal+5−6

@@ -78,7 +78,6 @@ Library

7878 Elm.Compiler.Version,

7979 Generate.JavaScript,

8080 Generate.JavaScript.BuiltIn,

81− Generate.JavaScript.Crash,

8281 Generate.JavaScript.Helpers,

8382 Generate.JavaScript.Literal,

8483 Generate.JavaScript.Port,

@@ -87,9 +86,9 @@ Library

8786 Nitpick.PatternMatches,

8887 Nitpick.TopLevelTypes,

8988 Optimize,

90− Optimize.Cases,

91− Optimize.Substitute,

92− Optimize.TailCalls,

89+ Optimize.Environment,

90+ Optimize.Patterns,

91+ Optimize.Patterns.DecisionTree,

9392 Parse.Binop,

9493 Parse.Declaration,

9594 Parse.Expression,

@@ -100,7 +99,6 @@ Library

10099 Parse.Pattern,

101100 Parse.Type,

102101 Reporting.Annotation,

103− Reporting.Crash,

104102 Reporting.Error,

105103 Reporting.Error.Canonicalize,

106104 Reporting.Error.Docs,

@@ -150,7 +148,8 @@ Library

150148 text >= 1 && < 2,

151149 transformers >= 0.2 && < 0.5,

152150 union-find >= 0.2 && < 0.3,

153− unordered-containers >= 0.1 && < 0.3

151+ unordered-containers >= 0.1 && < 0.3,

152+ wl-pprint

154153

155154

156155Executable elm

src/AST/Expression/General.hs−5

@@ -16,7 +16,6 @@ import qualified AST.Pattern as Pattern

1616import qualified AST.Type as Type

1717import qualified AST.Variable as Var

1818import qualified Reporting.Annotation as A

19−import qualified Reporting.Crash as Crash

2019import qualified Reporting.PrettyPrint as P

2120

2221

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

5958 -- for type checking and code gen only

6059 | Port (PortImpl (Expr ann def var typ) typ)

6160 | GLShader String String Literal.GLShaderTipe

62− | Crash Crash.Details

6361 deriving (Show)

6462

6563

@@ -249,9 +247,6 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

249247 Port portImpl ->

250248 P.pretty dealiaser needsParens portImpl

251249

252− Crash details ->

253− P.text ("<crash:" ++ Crash.summary details ++ ">")

254−

255250

256251instance P.Pretty (PortImpl expr tipe) where

257252 pretty _ _ impl =

src/AST/Expression/Optimized.hs+46−15

@@ -1,36 +1,67 @@

11{-# OPTIONS_GHC -Wall #-}

22module AST.Expression.Optimized

3− ( Expr, Expr'

4− , Def(..)

5− , Facts(..), dummyFacts

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

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

65 ) where

87import qualified AST.Expression.General as General

9−import qualified AST.Pattern as Pattern

8+import qualified AST.Literal as Literal

9+import qualified AST.Module.Name as ModuleName

1010import qualified AST.Type as Type

1111import qualified AST.Variable as Var

12+import qualified Optimize.Patterns.DecisionTree as DT

13+import qualified Reporting.Region as R

1214

1315

14−type Expr =

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

16−

17−

18−type Expr' =

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

2016

17+-- DEFINITIONS

2118

2219data Def

23− = Definition Facts Pattern.Optimized Expr

24− deriving (Show)

20+ = Def Facts String Expr

21+ | TailDef Facts String [String] Expr

2522

2623

2724data Facts = Facts

28− { tailRecursionDetails :: Maybe String

25+ { home :: Maybe ModuleName.Canonical

2926 , dependencies :: [Var.TopLevel]

3027 }

31− deriving (Show)

3228

3329

3430dummyFacts :: Facts

3531dummyFacts =

36− Facts Nothing []

32+ Facts Nothing []

33+

34+

35+-- EXPRESSIONS

36+

37+data Expr

38+ = Literal Literal.Literal

39+ | Var Var.Canonical

40+ | Range Expr Expr

41+ | ExplicitList [Expr]

42+ | Binop Var.Canonical Expr Expr

43+ | Function [String] Expr

44+ | Call Expr [Expr]

45+ | TailCall String [String] [Expr]

46+ | If [(Expr, Expr)] Expr

47+ | Let [Def] Expr

48+ | Case String (DT.DecisionTree Jump) [(Int, Branch)]

49+ | Data String [Expr]

50+ | DataAccess Expr Int

51+ | Access Expr String

52+ | Update Expr [(String, Expr)]

53+ | Record [(String, Expr)]

54+ | Port (General.PortImpl Expr Type.Canonical)

55+ | GLShader String String Literal.GLShaderTipe

56+ | Crash R.Region (Maybe String)

57+

58+

59+data Jump

60+ = Inline Branch

61+ | Jump Int

62+

63+

64+data Branch = Branch

65+ { _substitutions :: [(String, DT.Path)]

66+ , _branch :: Expr

67+ }

src/AST/Module.hs+1−1

@@ -60,7 +60,7 @@ type CanonicalModule =

6060

6161

6262type Optimized =

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

63+ [Optimized.Def]

6464

6565

6666data Module docs imports exports body = Module

src/AST/Pattern.hs−4

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

3838 Pattern R.Region Var.Canonical

3939

4040

41−type Optimized =

42− Pattern () Var.Canonical

43−

44−

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

4642list end patterns =

4743 case patterns of

src/AST/Variable.hs+16

@@ -71,6 +71,22 @@ inCore home name =

7171

7272-- VARIABLE RECOGNIZERS

7373

74+isLocalHome :: Home -> Bool

75+isLocalHome home =

76+ case home of

77+ BuiltIn ->

78+ False

79+

80+ Module _ ->

81+ False

82+

83+ TopLevel _ ->

84+ True

85+

86+ Local ->

87+ True

88+

89+

7490is :: ModuleName.Raw -> String -> Canonical -> Bool

7591is home name var =

7692 var == inCore home name

src/Canonicalize.hs−3

@@ -487,9 +487,6 @@ expression env (A.A region validExpr) =

487487 GLShader uid src tipe ->

488488 Result.ok (GLShader uid src tipe)

489489

490− Crash details ->

491− Result.ok (Crash details)

492−

493490

494491pattern

495492 :: Env.Environment

src/Canonicalize/Sort.hs−3

@@ -108,9 +108,6 @@ reorder (A.A ann expression) =

108108 Task name expr tipe ->

109109 (\e -> Task name e tipe) <$> reorder expr

110110

111− Crash _ ->

112− return expression

113−

114111 -- Actually do some reordering

115112 Let defs body ->

116113 do body' <- reorder body

src/Generate/JavaScript.hs+189−409

@@ -2,34 +2,34 @@ module Generate.JavaScript (generate) where

33import Control.Applicative ((<$>),(<*>))

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

5−import Control.Monad.State

5+import Control.Monad.State as State

66import qualified Data.List as List

77import qualified Data.Map as Map

8−import qualified Data.Maybe as Maybe

8+import Language.ECMAScript3.PrettyPrint as ES

99import Language.ECMAScript3.Syntax

10+import qualified Text.PrettyPrint.Leijen as PP

1011

11−import AST.Expression.General as Expr

12−import qualified AST.Expression.Optimized as Opt

13−import qualified AST.Helpers as Help

14−import AST.Literal

12+import qualified AST.Expression.General as Expr

13+import AST.Expression.Optimized as Opt

14+import qualified AST.Literal as L

1515import qualified AST.Module as Module

1616import qualified AST.Module.Name as ModuleName

17−import qualified AST.Pattern as P

1817import qualified AST.Variable as Var

1918import Generate.JavaScript.Helpers as Help

2019import qualified Generate.JavaScript.BuiltIn as BuiltIn

21−import qualified Generate.JavaScript.Crash as Crash

2220import qualified Generate.JavaScript.Literal as Literal

2321import qualified Generate.JavaScript.Port as Port

2422import qualified Generate.JavaScript.Variable as Var

25−import qualified Optimize.Cases as Case

26−import qualified Reporting.Annotation as A

27−import qualified Reporting.Crash as Crash

23+import qualified Optimize.Patterns.DecisionTree as DT

2824

2925

3026generate :: Module.Optimized -> String

31−generate modul =

32− error "TODO" modul exprToCode

27+generate definitions =

28+ let

29+ stmts =

30+ State.evalState (mapM generateDef definitions) 0

31+ in

32+ PP.displayS (PP.renderPretty 0.4 120 (ES.prettyPrint stmts)) ""

3333

3434

3535-- CODE CHUNKS

@@ -81,39 +81,35 @@ toExpr code =

8181 case code of

8282 JsExpr expr ->

8383 expr

84+

8485 JsBlock stmts ->

8586 function [] stmts `call` []

8687

8788

88−-- TAIL CALL CONTEXT

89+-- DEFINITIONS

8990

90−type TailCallContext =

91− Maybe (String, [String], Label)

91+generateDef :: Opt.Def -> State Int (Statement ())

92+generateDef def =

93+ do (home, name, jsBody) <-

94+ case def of

95+ Opt.TailDef (Opt.Facts home _) name argNames body ->

96+ (,,) home name <$> generateTailFunction name argNames body

9297

98+ Opt.Def (Opt.Facts home _) name body ->

99+ (,,) home name <$> generateJsExpr body

93100

94−type Label =

95− Id ()

101+ return (VarDeclStmt () [ varDecl (Var.defName home name) jsBody ])

96102

97103

98104-- EXPRESSIONS

99105

100−toJsExpr :: Opt.Expr -> State Int (Expression ())

101−toJsExpr =

102− exprToJsExpr Nothing

103−

106+generateJsExpr :: Opt.Expr -> State Int (Expression ())

107+generateJsExpr optExpr =

108+ toExpr <$> generateCode optExpr

104109

105−toCode :: Opt.Expr -> State Int Code

106−toCode =

107− exprToCode Nothing

108110

109−

110−exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())

111−exprToJsExpr tcc canonicalExpr =

112− toExpr <$> exprToCode tcc canonicalExpr

113−

114−

115−exprToCode :: TailCallContext -> Opt.Expr -> State Int Code

116−exprToCode tcc annotatedExpr@(A.A _ expr) =

111+generateCode :: Opt.Expr -> State Int Code

112+generateCode expr =

117113 case expr of

118114 Var var ->

119115 jsExpr $ Var.canonical var

@@ -122,28 +118,28 @@ exprToCode tcc annotatedExpr@(A.A _ expr) =

122118 jsExpr (Literal.literal lit)

123119

124120 Range lo hi ->

125− do lo' <- toJsExpr lo

126− hi' <- toJsExpr hi

121+ do lo' <- generateJsExpr lo

122+ hi' <- generateJsExpr hi

127123 jsExpr $ BuiltIn.range lo' hi'

128124

129125 Access record field ->

130− do record' <- toJsExpr record

126+ do record' <- generateJsExpr record

131127 jsExpr $ DotRef () record' (var (Var.safe field))

132128

133129 Update record fields ->

134130 let

135131 fieldToJs (field, value) =

136− do jsValue <- toJsExpr value

132+ do jsValue <- generateJsExpr value

137133 return (Var.safe field, jsValue)

138134 in

139− do jsRecord <- toJsExpr record

135+ do jsRecord <- generateJsExpr record

140136 jsFields <- mapM fieldToJs fields

141137 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields

142138

143139 Record fields ->

144140 do fields' <-

145141 forM fields $ \(field, e) ->

146− (,) (Var.safe field) <$> toJsExpr e

142+ (,) (Var.safe field) <$> generateJsExpr e

147143

148144 let fieldMap =

149145 List.foldl' combine Map.empty fields'

@@ -163,70 +159,96 @@ exprToCode tcc annotatedExpr@(A.A _ expr) =

163159 Binop op leftExpr rightExpr ->

164160 binop op leftExpr rightExpr

165161

166− Lambda _ _ ->

167− generateFunction (Expr.collectLambdas annotatedExpr)

162+ Function args body ->

163+ generateFunction args body

168164

169− App _ _ ->

170− generateApplication tcc annotatedExpr

165+ Call func args ->

166+ let

167+ arity = length args

168+ aN = "A" ++ show arity

169+ in

170+ do jsFunc <- generateJsExpr func

171+ jsArgs <- mapM generateJsExpr args

172+ jsExpr $

173+ if 2 <= arity && arity <= 9 then

174+ ref aN `call` (jsFunc:jsArgs)

175+ else

176+ foldl1 (<|) (jsFunc:jsArgs)

177+

178+ TailCall name argNames args ->

179+ let

180+ reassign name tempName =

181+ ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))

182+ in

183+ do args' <- mapM generateJsExpr args

184+ tempNames <- mapM (\_ -> Var.fresh) args

185+ jsBlock $

186+ VarDeclStmt () (zipWith varDecl tempNames args')

187+ : zipWith reassign argNames tempNames

188+ ++ [ContinueStmt () (Just (Id () name))]

171189

172190 Let defs body ->

173− generateLet tcc defs body

191+ do stmts <- mapM generateDef defs

192+ code <- generateCode body

193+ jsBlock (stmts ++ toStatementList code)

174194

175195 If branches finally ->

176− generateIf tcc branches finally

196+ generateIf branches finally

177197

178− Case expr branches ->

179− generateCase tcc expr branches

198+ Case root decisionTree branches ->

199+ JsBlock <$> generateCase root decisionTree branches

180200

181201 ExplicitList elements ->

182− do jsElements <- mapM toJsExpr elements

202+ do jsElements <- mapM generateJsExpr elements

183203 jsExpr $ BuiltIn.list jsElements

184204

185205 Data tag members ->

186− do jsMembers <- mapM toJsExpr members

206+ do jsMembers <- mapM generateJsExpr members

187207 jsExpr $ ObjectLit () (ctor : fields jsMembers)

188208 where

189209 ctor = (prop "ctor", string tag)

190210 fields =

191211 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

192212

213+ DataAccess dataExpr index ->

214+ do jsDataExpr <- generateJsExpr dataExpr

215+ jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))

216+

193217 GLShader _uid src _tipe ->

194− jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (Str src))]

218+ jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]

195219

196220 Port impl ->

197221 case impl of

198− In name portType ->

222+ Expr.In name portType ->

199223 jsExpr (Port.inbound name portType)

200224

201− Out name expr portType ->

202− do expr' <- toJsExpr expr

225+ Expr.Out name expr portType ->

226+ do expr' <- generateJsExpr expr

203227 jsExpr (Port.outbound name expr' portType)

204228

205− Task name expr portType ->

206− do expr' <- toJsExpr expr

229+ Expr.Task name expr portType ->

230+ do expr' <- generateJsExpr expr

207231 jsExpr (Port.task name expr' portType)

208232

209− Crash details ->

210− jsExpr $ Crash.crash details

233+ Crash region maybeCaseCrashValue ->

234+ jsExpr $ BuiltIn.crash region maybeCaseCrashValue

211235

212236

213237-- FUNCTIONS

214238

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

216−generateFunction (args, initialBody) =

217− do (argVars, patternDefs) <- destructuredArgs args

218− code <- generateLet Nothing patternDefs initialBody

219− jsExpr (generateFunctionWithArity argVars code)

239+generateFunction :: [String] -> Opt.Expr -> State Int Code

240+generateFunction args body =

241+ do code <- generateCode body

242+ jsExpr (generateFunctionWithArity args code)

220243

221244

222−generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())

223−generateTailFunction name (args, initialBody) =

224− do (argVars, patternDefs) <- destructuredArgs args

225− label <- Id () <$> Case.newVar

226− code <- generateLet (Just (name, argVars, label)) patternDefs initialBody

227− let whileLoop =

228− JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]

229− return (generateFunctionWithArity argVars whileLoop)

245+generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())

246+generateTailFunction name args body =

247+ do code <- generateCode body

248+ return $ generateFunctionWithArity args $ JsBlock $ (:[]) $

249+ LabelledStmt ()

250+ (Id () name)

251+ (WhileStmt () (BoolLit () True) (toStatement code))

230252

231253

232254generateFunctionWithArity :: [String] -> Code -> Expression ()

@@ -247,105 +269,16 @@ generateFunctionWithArity args code =

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

248270

249271

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

251−destructuredArgs args =

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

253− return (argVars, Maybe.catMaybes maybePatternDefs)

254−

255−

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

257−destructPattern pattern@(A.A ann pat) =

258− case pat of

259− P.Var x ->

260− return (Var.safe x, Nothing)

261−

262− _ ->

263− do arg <- Case.newVar

264− return

265− ( arg

266− , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))

267− )

268−

269−

270−-- APPLICATIONS

271−

272−generateApplication :: TailCallContext -> Opt.Expr -> State Int Code

273−generateApplication tcc expr =

274− let

275− (func:args) =

276− Expr.collectApps expr

277−

278− arity =

279− length args

280−

281− reassign name tempName =

282− ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))

283−

284− aN =

285− "A" ++ show arity

286− in

287− case isTailCall tcc func arity of

288− Just (argNames, label) ->

289− do args' <- mapM toJsExpr args

290− tempNames <- mapM (\_ -> Case.newVar) args

291− jsBlock $

292− VarDeclStmt () (zipWith varDecl tempNames args')

293− : zipWith reassign argNames tempNames

294− ++ [ContinueStmt () (Just label)]

295−

296− _ ->

297− do func' <- toJsExpr func

298− args' <- mapM toJsExpr args

299− jsExpr $

300− if 2 <= arity && arity <= 9 then

301− ref aN `call` (func':args')

302− else

303− foldl1 (<|) (func':args')

304−

305−

306−isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)

307−isTailCall tcc (A.A _ func) arity =

308− case (func, tcc) of

309− (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->

310− if name == tcName && length tcArgs == arity then

311− Just (tcArgs, tcLabel)

312− else

313− Nothing

314−

315− (Var (Var.Canonical (Var.TopLevel _) name), Just (tcName, tcArgs, tcLabel)) ->

316− if name == tcName && length tcArgs == arity then

317− Just (tcArgs, tcLabel)

318− else

319− Nothing

320−

321− _ ->

322− Nothing

323−

324−

325−-- LET EXPRESSIONS

326−

327−generateLet

328− :: TailCallContext

329− -> [Opt.Def]

330− -> Opt.Expr

331− -> State Int Code

332−generateLet tcc givenDefs givenBody =

333− do let (defs, body) = flattenLets givenDefs givenBody

334− stmts <- concat <$> mapM defToStatements defs

335− code <- exprToCode tcc body

336− jsBlock (stmts ++ toStatementList code)

337−

338−

339272-- GENERATE IFS

340273

341−generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code

342−generateIf tcc givenBranches givenFinally =

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

275+generateIf givenBranches givenFinally =

343276 let

344277 (branches, finally) =

345278 crushIfs givenBranches givenFinally

346279

347280 convertBranch (condition, expr) =

348− (,) <$> toJsExpr condition <*> exprToCode tcc expr

281+ (,) <$> generateJsExpr condition <*> generateCode expr

349282

350283 ifExpression (condition, branch) otherwise =

351284 CondExpr () condition branch otherwise

@@ -354,7 +287,7 @@ generateIf tcc givenBranches givenFinally =

354287 IfStmt () condition branch otherwise

355288 in

356289 do jsBranches <- mapM convertBranch branches

357− jsFinally <- exprToCode tcc finally

290+ jsFinally <- generateCode finally

358291

359292 if any isBlock (jsFinally : map snd jsBranches)

360293 then

@@ -380,263 +313,146 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

380313 case unvisitedBranches of

381314 [] ->

382315 case finally of

383− A.A _ (If subBranches subFinally) ->

316+ If subBranches subFinally ->

384317 crushIfsHelp visitedBranches subBranches subFinally

385318

386319 _ ->

387320 (reverse visitedBranches, finally)

388321

389− (A.A _ (Literal (Boolean True)), branch) : _ ->

322+ (Literal (L.Boolean True), branch) : _ ->

390323 crushIfsHelp visitedBranches [] branch

391324

392325 visiting : unvisited ->

393326 crushIfsHelp (visiting : visitedBranches) unvisited finally

394327

395328

329+-- CASE EXPRESSIONS

396330

397−-- DEFINITIONS

398−

399−defToStatements :: Opt.Def -> State Int [Statement ()]

400−defToStatements (Opt.Definition facts pattern expr) =

401− case Opt.tailRecursionDetails facts of

402− Just name ->

403− do func <- generateTailFunction name (Expr.collectLambdas expr)

404− return [ VarDeclStmt () [ varDecl name func ] ]

405−

406− Nothing ->

407− defToStatementsHelp facts pattern =<< toJsExpr expr

331+generateCase

332+ :: String

333+ -> DT.DecisionTree Opt.Jump

334+ -> [(Int, Opt.Branch)]

335+ -> State Int [Statement ()]

336+generateCase root decisionTree jumpBranches =

337+ do decider <- generateDecisionTree root decisionTree

338+ foldM (goto root) decider jumpBranches

408339

409340

410−defToStatementsHelp

411− :: Opt.Facts

412− -> P.Optimized

413− -> Expression ()

414− -> State Int [Statement ()]

415−defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =

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

342+goto root decider (target, branch) =

416343 let

417− define x =

418− varDecl x jsExpr

344+ deciderStmt =

345+ LabelledStmt ()

346+ (targetLabel root target)

347+ (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))

419348 in

420− case pattern of

421− P.Var x ->

422− if Help.isOp x then

423− let

424− op = LBracket () (ref "_op") (string x)

425− in

426− return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]

427− else

428− return [ VarDeclStmt () [ define (Var.safe x) ] ]

429−

430− P.Record fields ->

431− let

432− setField name =

433− varDecl name (obj ["$",name])

434− in

435− return [ VarDeclStmt () (define "$" : map setField fields) ]

436−

437− P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

438− return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

439− where

440− vars = getVars patterns

441− getVars patterns =

442− case patterns of

443− A.A _ (P.Var x) : rest ->

444− (Var.safe x :) `fmap` getVars rest

445− [] ->

446− Just []

447− _ ->

448− Nothing

449−

450− decl x n = varDecl x (obj ["$","_" ++ show n])

451− setup vars

452− | Help.isTuple name = define "$" : vars

453− | otherwise = define "_raw" : safeAssign : vars

454−

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

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

457− exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))

458−

459− _ ->

460− do defs' <- concat <$> mapM toDef vars

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

462− where

463− vars = P.boundVarList annPattern

464− mkVar = A.A () . localVar

465− toDef y =

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

467− pat = A.A () (P.Var y)

468− in

469− defToStatements (Opt.Definition facts pat expr)

349+ do stmts <- generateBranch root branch

350+ return (deciderStmt : stmts)

470351

471352

472−-- CASE EXPRESSIONS

353+targetLabel :: String -> Int -> Id ()

354+targetLabel root target =

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

473356

474−generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code

475−generateCase tcc expr branches =

476− do (tempVar, initialMatch) <-

477− Case.toMatch branches

478−

479− (revisedMatch, stmt) <-

480− case expr of

481− A.A _ (Var (Var.Canonical Var.Local x)) ->

482− return (Case.matchSubst [(tempVar, Var.safe x)] initialMatch, [])

483−

484− A.A _ (Var (Var.Canonical (Var.TopLevel _) x)) ->

485− return (Case.matchSubst [(tempVar, Var.safe x)] initialMatch, [])

486−

487− _ ->

488− do expr' <- toJsExpr expr

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

490−

491− match' <- match tcc revisedMatch

492−

493− jsBlock (stmt ++ match')

494−

495−

496−match :: TailCallContext -> Case.Match -> State Int [Statement ()]

497−match tcc mtch =

498− case mtch of

499− Case.Match name clauses mtch' ->

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

501− mtch'' <- match tcc mtch'

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

503− where

504− isLiteral p =

505− case p of

506− Case.Clause (Right _) _ _ ->

507− True

508− _ ->

509− False

510−

511− access name =

512− if any isLiteral clauses then

513− obj [name]

514− else

515− obj (Help.splitDots name ++ ["ctor"])

516−

517− format isChars expr =

518− if or isChars then

519− InfixExpr () OpAdd expr (string "")

520− else

521− expr

522−

523− Case.Fail ->

524− return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]

525−

526− Case.Break ->

527− return [BreakStmt () Nothing]

528−

529− Case.Other expr ->

530− toStatementList <$> exprToCode tcc expr

531−

532− Case.Seq ms ->

533− concat <$> mapM (match tcc) (dropEnd [] ms)

534− where

535− dropEnd acc [] = acc

536− dropEnd acc (m:ms) =

537− case m of

538− Case.Other _ -> acc ++ [m]

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

540−

541−

542−clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())

543−clause tcc variable (Case.Clause value vars mtch) =

544− do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)

545− return ((,) isChar (CaseClause () pattern statemens))

546− where

547− vars' =

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

549357

550− (isChar, pattern) =

551− case value of

552− Right (Chr c) -> (True, string [c])

553− _ ->

554− (,) False $

555− case value of

556− Right (Boolean b) -> BoolLit () b

557− Right lit -> Literal.literal lit

558− Left (Var.Canonical _ name) ->

559− string name

358+generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]

359+generateDecisionTree root decisionTree =

360+ case decisionTree of

361+ DT.Match (Opt.Inline branch) ->

362+ generateBranch root branch

560363

364+ DT.Match (Opt.Jump target) ->

365+ return [ BreakStmt () (Just (targetLabel root target)) ]

561366

562−flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)

563−flattenLets defs lexpr@(A.A _ expr) =

564− case expr of

565− Let ds body -> flattenLets (defs ++ ds) body

566− _ -> (defs, lexpr)

367+ DT.Decision testPath edges fallback ->

368+ do accessExpr <- generateJsExpr (pathToExpr root testPath)

567369

370+ let testExpr =

371+ case fst (head edges) of

372+ DT.Constructor _ ->

373+ DotRef () accessExpr (Id () "ctor")

568374

569−-- BINARY OPERATORS

375+ DT.Literal _ ->

376+ accessExpr

570377

571−binop

572− :: Var.Canonical

573− -> Opt.Expr

574− -> Opt.Expr

575− -> State Int Code

576−binop func left right

577− | func == Var.Canonical Var.BuiltIn "::" =

578− toCode (A.A () (Data "::" [left,right]))

378+ caseClauses <- mapM (edgeToCaseClause root) edges

379+ caseDefault <- fallbackToDefault root fallback

579380

580− | func == forwardCompose =

581− compose (collectLeftAssoc forwardCompose left right)

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

582382

583− | func == backwardCompose =

584− compose (collectRightAssoc backwardCompose left right)

585383

586− | func == forwardApply =

587− pipe (collectLeftAssoc forwardApply left right)

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

385+edgeToCaseClause root (test, subTree) =

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

588387

589− | func == backwardApply =

590− pipe (collectRightAssoc backwardApply left right)

591388

592− | otherwise =

593− do jsLeft <- toJsExpr left

594− jsRight <- toJsExpr right

595− jsExpr (makeExpr func jsLeft jsRight)

389+testToExpr :: DT.Test -> Expression ()

390+testToExpr test =

391+ case test of

392+ DT.Constructor (Var.Canonical _ tag) ->

393+ StringLit () tag

596394

395+ DT.Literal (L.Chr char) ->

396+ StringLit () [char]

597397

598−-- CONTROL FLOW OPERATOR HELPERS

398+ DT.Literal lit ->

399+ Literal.literal lit

599400

600−apply :: Expression () -> Expression () -> Expression ()

601−apply arg func =

602− func <| arg

603401

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

403+fallbackToDefault root fallback =

404+ case fallback of

405+ Nothing ->

406+ return []

604407

605−compose :: [Opt.Expr] -> State Int Code

606−compose functions =

607− do jsFunctions <- mapM toJsExpr functions

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

408+ Just subTree ->

409+ do stmts <- generateDecisionTree root subTree

410+ return [ CaseDefault () stmts ]

609411

610412

611−pipe :: [Opt.Expr] -> State Int Code

612−pipe expressions =

613− do (value:functions) <- mapM toJsExpr expressions

614− jsExpr $ List.foldl' apply value functions

413+generateBranch :: String -> Opt.Branch -> State Int [Statement ()]

414+generateBranch root (Opt.Branch substitutions expr) =

415+ do subts <- mapM (loadPath root) substitutions

416+ code <- generateCode expr

417+ return (subts ++ toStatementList code)

615418

616419

617−forwardCompose :: Var.Canonical

618−forwardCompose =

619− inBasics ">>"

420+loadPath :: String -> (String, DT.Path) -> State Int (Statement ())

421+loadPath root (name, path) =

422+ do jsAccessExpr <- generateJsExpr (pathToExpr root path)

423+ return $ VarDeclStmt () [ varDecl name jsAccessExpr ]

620424

621425

622−backwardCompose :: Var.Canonical

623−backwardCompose =

624− inBasics "<<"

426+pathToExpr :: String -> DT.Path -> Opt.Expr

427+pathToExpr root fullPath =

428+ go (Opt.Var (Var.local root)) fullPath

429+ where

430+ go expr path =

431+ case path of

432+ DT.Position index subpath ->

433+ go (Opt.DataAccess expr index) subpath

625434

435+ DT.Field field subpath ->

436+ go (Opt.Access expr field) subpath

626437

627−forwardApply :: Var.Canonical

628−forwardApply =

629− inBasics "|>"

438+ DT.Empty ->

439+ expr

630440

441+ DT.Alias ->

442+ expr

631443

632−backwardApply :: Var.Canonical

633−backwardApply =

634− inBasics "<|"

635444

445+-- BINARY OPERATORS

636446

637−inBasics :: String -> Var.Canonical

638−inBasics name =

639− Var.inCore ["Basics"] name

447+binop

448+ :: Var.Canonical

449+ -> Opt.Expr

450+ -> Opt.Expr

451+ -> State Int Code

452+binop func left right =

453+ do jsLeft <- generateJsExpr left

454+ jsRight <- generateJsExpr right

455+ jsExpr (makeExpr func jsLeft jsRight)

640456

641457

642458-- BINARY OPERATOR HELPERS

@@ -676,7 +492,6 @@ infixOps =

676492specialOps :: [(String, Expression () -> Expression () -> Expression ())]

677493specialOps =

678494 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

679− , (,) "|>" $ flip (<|)

680495 , (,) "==" $ \a b -> BuiltIn.eq a b

681496 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)

682497 , (,) "<" $ cmp OpLT 0

@@ -690,38 +505,3 @@ specialOps =

690505cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()

691506cmp op n a b =

692507 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)

693−

694−

695−-- BINARY OPERATOR COLLECTORS

696−

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

698−collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

699−collectRightAssoc desiredOp left right =

700− collectRightAssocHelp desiredOp [left] right

701−

702−

703−collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

704−collectRightAssocHelp desiredOp exprList expr =

705− case expr of

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

707− collectRightAssocHelp desiredOp (left : exprList) right

708−

709− _ ->

710− expr : exprList

711−

712−

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

714−collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

715−collectLeftAssoc desiredOp left right =

716− collectLeftAssocHelp desiredOp [right] left

717−

718−

719−collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

720−collectLeftAssocHelp desiredOp exprList expr =

721− case expr of

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

723− collectLeftAssocHelp desiredOp (right : exprList) left

724−

725− _ ->

726− expr : exprList

727−

src/Generate/JavaScript/BuiltIn.hs+47−6

@@ -2,12 +2,20 @@ module Generate.JavaScript.BuiltIn where

33import qualified Language.ECMAScript3.Syntax as JS

5+import Generate.JavaScript.Helpers

6+import qualified Reporting.Region as R

9+utils :: String -> [JS.Expression ()] -> JS.Expression ()

10+utils func args =

11+ error "TODO"

12+

513

614-- LITERALS

715

816character :: Char -> JS.Expression ()

917character char =

10− error "TODO - utils.chr" JS.StringLit () [char]

18+ utils "chr" [ JS.StringLit () [char] ]

1119

1220

1321string :: String -> JS.Expression ()

@@ -19,28 +27,61 @@ string str =

1927

2028list :: [JS.Expression ()] -> JS.Expression ()

2129list elements =

22− error "TODO - utils.list" (JS.ArrayLit () elements)

30+ utils "list" [ JS.ArrayLit () elements ]

2331

2432

2533range :: JS.Expression () -> JS.Expression () -> JS.Expression ()

2634range low high =

27− error "TODO - utils.range" low high

35+ utils "range" [ low, high ]

2836

2937

3038-- RECORDS

3139

3240recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expression ()

3341recordUpdate record fields =

34− error "TODO - utils.update" record fields

42+ utils "update" [ record, JS.ArrayLit () (map toKeyValue fields) ]

43+

44+

45+toKeyValue :: (String, JS.Expression ()) -> JS.Expression ()

46+toKeyValue (key, value) =

47+ JS.ArrayLit () [ JS.StringLit () key, value ]

3548

3649

3750-- COMPARISIONS

3851

3952eq :: JS.Expression () -> JS.Expression () -> JS.Expression ()

4053eq left right =

41− error "TODO - utils.eq" left right

54+ utils "eq" [ left, right ]

4255

4356

4457compare :: JS.Expression () -> JS.Expression () -> JS.Expression ()

4558compare left right =

46− error "TODO - utils.compare" left right

59+ utils "compare" [ left, right ]

60+

61+

62+-- CRASH

63+

64+crash :: R.Region -> Maybe String -> JS.Expression ()

65+crash region maybeCaseCrashValue =

66+ case maybeCaseCrashValue of

67+ Nothing ->

68+ utils "crash" [ regionToJs region ]

69+

70+ Just crashValue ->

71+ utils "caseCrash" [ regionToJs region, ref crashValue ]

72+

73+

74+regionToJs :: R.Region -> JS.Expression ()

75+regionToJs (R.Region start end) =

76+ JS.ObjectLit ()

77+ [ ( prop "start", positionToJs start )

78+ , ( prop "end", positionToJs end )

79+ ]

80+

81+

82+positionToJs :: R.Position -> JS.Expression ()

83+positionToJs (R.Position line column) =

84+ JS.ObjectLit ()

85+ [ ( prop "line", JS.IntLit () line )

86+ , ( prop "column", JS.IntLit () column )

87+ ]

src/Generate/JavaScript/Crash.hsdeleted−32

@@ -1,32 +0,0 @@

1−module Generate.JavaScript.Crash where

2−

3−import Language.ECMAScript3.Syntax (Expression)

4−

5−import Generate.JavaScript.Helpers (call, obj, ref, string)

6−import qualified Reporting.Crash as Crash

7−import qualified Reporting.Region as R

8−

9−

10−localModuleName :: String

11−localModuleName =

12− "$moduleName"

13−

14−

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

16−crash details =

17− case details of

18− Crash.IncompleteMultiIf region ->

19− obj ["_U","badIf"]

20− `call`

21− [ ref localModuleName

22− , string (R.toString region)

23− ]

24−

25− Crash.IncompletePatternMatch _region ->

26− obj ["_U","badCase"]

27− `call`

28− [ ref localModuleName

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

30− ]

31−

32−

src/Generate/JavaScript/Variable.hs+28−6

@@ -1,5 +1,6 @@

1−module Generate.JavaScript.Variable (canonical, safe) where

1+module Generate.JavaScript.Variable (fresh, canonical, defName, safe) where

3+import qualified Control.Monad.State as State

34import qualified Data.List as List

45import qualified Data.Set as Set

56import qualified Language.ECMAScript3.Syntax as JS

@@ -11,6 +12,27 @@ import qualified Elm.Package as Pkg

1112import qualified Generate.JavaScript.Helpers as JS

1213

1314

15+-- FRESH NAMES

16+

17+fresh :: State.State Int String

18+fresh =

19+ do n <- State.get

20+ State.modify (+1)

21+ return ("_v" ++ show n)

22+

23+

24+-- DEF NAMES

25+

26+defName :: Maybe ModuleName.Canonical -> String -> String

27+defName maybeHome name =

28+ case maybeHome of

29+ Nothing ->

30+ safe name

31+

32+ Just home ->

33+ canonicalPrefix home (safe name)

34+

35+

1436-- INSTANTIATE VARIABLES

1537

1638canonical :: Var.Canonical -> JS.Expression ()

@@ -29,21 +51,21 @@ addRoot home name =

2951 name

3052

3153 Var.TopLevel moduleName ->

32− canonicalName moduleName name

54+ canonicalPrefix moduleName name

3355

3456 Var.BuiltIn ->

3557 name

3658

3759 Var.Module moduleName ->

38− canonicalName moduleName name

60+ canonicalPrefix moduleName name

3961

4062

41−canonicalName :: ModuleName.Canonical -> String -> String

42−canonicalName (ModuleName.Canonical (Pkg.Name user project) moduleName) name =

63+canonicalPrefix :: ModuleName.Canonical -> String -> String

64+canonicalPrefix (ModuleName.Canonical (Pkg.Name user project) moduleName) name =

4365 map (swap '-' '_') user

4466 ++ '$' : map (swap '-' '_') project

4567 ++ '$' : List.intercalate "$" moduleName

46− ++ '$' : name

68+ ++ '$' : safe name

4769

4870

4971swap :: Char -> Char -> Char -> Char

src/Nitpick/PatternMatches.hs−3

@@ -181,9 +181,6 @@ checkExpression tagDict (A.A region expression) =

181181 E.GLShader _ _ _ ->

182182 Result.ok ()

183183

184− E.Crash _ ->

185− Result.ok ()

186−

187184

188185-- CHECK PATTERNS

189186

src/Optimize.hs+456−12

@@ -1,19 +1,463 @@

1−module Optimize where

1+module Optimize (optimize) where

3−import qualified AST.Module as M

4−import qualified Optimize.TailCalls as TC

3+import Control.Applicative

4+import qualified Control.Monad as M

5+import qualified Data.Map as Map

6+import qualified Data.Traversable as T

8+import qualified AST.Expression.General as Expr

9+import qualified AST.Expression.Canonical as Can

10+import qualified AST.Expression.Optimized as Opt

11+import qualified AST.Module as Module

12+import qualified AST.Module.Name as ModuleName

13+import qualified AST.Pattern as P

14+import qualified AST.Variable as Var

15+import Elm.Utils ((|>))

16+import qualified Optimize.Environment as Env

17+import qualified Optimize.Patterns as Patterns

18+import qualified Reporting.Annotation as A

19+import qualified Reporting.Region as R

620

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

8−optimize modul =

21+

22+-- OPTIMIZE - turn a canonical module into a list of optimized defs

23+

24+optimize :: Module.CanonicalModule -> Module.Optimized

25+optimize (Module.Module home _ _ _ _ body) =

26+ let

27+ (defs, _) =

28+ flattenLets [] (Module.program body)

29+

30+ variantInfo (_, tags) =

31+ let

32+ variants = length tags

33+ in

34+ map (\(tag, _) -> (Var.fromModule home tag, variants)) tags

35+

36+ variantDict =

37+ Module.datatypes body

38+ |> Map.elems

39+ |> concatMap variantInfo

40+ |> Map.fromList

41+ |> Map.insert (Var.builtin "_Tuple2") 1

42+ in

43+ Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)

44+

45+

46+flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)

47+flattenLets defs annExpr@(A.A _ expr) =

48+ case expr of

49+ Expr.Let ds body ->

50+ flattenLets (defs ++ ds) body

51+

52+ _ ->

53+ (defs, annExpr)

54+

55+

56+-- CONVERT DEFINITIONS

57+

58+optimizeDef :: Maybe ModuleName.Canonical -> Can.Def -> Env.Optimizer [Opt.Def]

59+optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expression _) =

60+ let

61+ (args, rawBody) =

62+ Expr.collectLambdas expression

63+ in

64+ case (ptrn, args) of

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

66+

67+ do htc <- Env.getTailCall

68+ Env.setTailCall False

69+

70+ (args, body) <- optimizeFunction (Just name) args rawBody

71+

72+ isTailCall <- Env.getTailCall

73+ Env.setTailCall htc

74+

75+ let facts = Opt.Facts home deps

76+

77+ return $

78+ if isTailCall then

79+

80+ [ Opt.TailDef facts name args body ]

81+

82+ else

83+

84+ [ Opt.Def facts name (Opt.Function args body) ]

85+

86+ (P.Var name, []) ->

87+

88+ do hasTailCall <- Env.getTailCall

89+ body <- optimizeExpr Nothing rawBody

90+ Env.setTailCall hasTailCall

91+ return [ Opt.Def (Opt.Facts home deps) name body ]

92+

93+ (_, []) ->

94+

95+ do name <- Env.freshName

96+ optBody <- optimizeExpr Nothing rawBody

97+ let optDef = Opt.Def (Opt.Facts home deps) name optBody

98+ return (optDef : patternToDefs home name pattern)

99+

100+ _ ->

101+ error "there should never be a function where the name is not a P.Var"

102+

103+

104+-- OPTIMIZE FUNCTION

105+

106+optimizeFunction

107+ :: Maybe String

108+ -> [P.CanonicalPattern]

109+ -> Can.Expr

110+ -> Env.Optimizer ([String], Opt.Expr)

111+optimizeFunction maybeName patterns givenBody =

112+ do (argNames, body) <- M.foldM depatternArgs ([], givenBody) (reverse patterns)

113+ optBody <- optimizeExpr (makeContext argNames =<< maybeName) body

114+ return (argNames, optBody)

115+

116+

117+makeContext :: [String] -> String -> Context

118+makeContext argNames name =

119+ Just (name, length argNames, argNames)

120+

121+

122+depatternArgs

123+ :: ([String], Can.Expr)

124+ -> P.CanonicalPattern

125+ -> Env.Optimizer ([String], Can.Expr)

126+depatternArgs (names, rawExpr) ptrn =

127+ do (name, expr) <- depattern ptrn rawExpr

128+ return (name : names, expr)

129+

130+

131+patternToDefs

132+ :: Maybe ModuleName.Canonical

133+ -> String

134+ -> P.CanonicalPattern

135+ -> [Opt.Def]

136+patternToDefs home rootName pattern =

9137 let

10− canonicalBody =

11− M.body modul

138+ (deps, rootExpr) =

139+ case home of

140+ Nothing ->

141+ ( []

142+ , Opt.Var (Var.local rootName)

143+ )

12144

13− optimizedProgram =

14− TC.optimize (M.program canonicalBody)

145+ Just moduleName ->

146+ ( [ Var.TopLevelVar moduleName rootName ]

147+ , Opt.Var (Var.topLevel moduleName rootName)

148+ )

15149

16− optimizedBody =

17− canonicalBody { M.program = optimizedProgram }

150+ toDef (name, accessExpr) =

151+ Opt.Def (Opt.Facts home deps) name accessExpr

18152 in

19− modul { M.body = optimizedBody }

153+ map toDef (substitutions rootExpr pattern)

154+

155+

156+substitutions :: Opt.Expr -> P.CanonicalPattern -> [(String, Opt.Expr)]

157+substitutions expr (A.A _ pattern) =

158+ case pattern of

159+ P.Var name ->

160+ [ (name, expr) ]

161+

162+ P.Literal _ ->

163+ []

164+

165+ P.Record fields ->

166+ map (\name -> (name, Opt.Access expr name)) fields

167+

168+ P.Anything ->

169+ []

170+

171+ P.Alias alias realPattern ->

172+ (alias, expr) : substitutions expr realPattern

173+

174+ P.Data _ patterns ->

175+ concat (zipWith (substitutions . Opt.DataAccess expr) [0..] patterns)

176+

177+

178+-- OPTIMIZE EXPRESSIONS

179+

180+type Context = Maybe (String, Int, [String])

181+

182+

183+{-| This optimizer detects tail calls. The `Context` holds a function name,

184+function arity, and list of argument names. If a tail call is possible, the

185+`Context` will be filled in and we check any function we run into. If we go

186+down a route that cannot possibly have tail calls, we remove the context.

187+-}

188+optimizeExpr :: Context -> Can.Expr -> Env.Optimizer Opt.Expr

189+optimizeExpr context annExpr@(A.A region expression) =

190+ let

191+ keepLooking =

192+ optimizeExpr context

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

194+ -- tail call

195+

196+ justConvert =

197+ optimizeExpr Nothing

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

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

200+ in

201+ case expression of

202+ Expr.Literal lit ->

203+ pure (Opt.Literal lit)

204+

205+ Expr.Var name ->

206+ if name == Var.inCore ["Debug"] "crash" then

207+ pure (Opt.Crash region Nothing)

208+

209+ else

210+ pure (Opt.Var name)

211+

212+ Expr.Range lowExpr highExpr ->

213+ Opt.Range

214+ <$> justConvert lowExpr

215+ <*> justConvert highExpr

216+

217+ Expr.ExplicitList elements ->

218+ Opt.ExplicitList

219+ <$> T.traverse justConvert elements

220+

221+ Expr.Binop op leftExpr rightExpr ->

222+ optimizeBinop context region op leftExpr rightExpr

223+

224+ Expr.Lambda _ _ ->

225+ let

226+ (patterns, body) =

227+ Expr.collectLambdas annExpr

228+ in

229+ uncurry Opt.Function <$> optimizeFunction Nothing patterns body

230+

231+ Expr.App _ _ ->

232+ let

233+ (func:args) =

234+ Expr.collectApps annExpr

235+ in

236+ case isTailCall context func (length args) of

237+ Just (name, argNames) ->

238+ do optArgs <- T.traverse justConvert args

239+ Env.setTailCall True

240+ return (Opt.TailCall name argNames optArgs)

241+

242+ Nothing ->

243+ do hasTailCall <- Env.getTailCall

244+ optFunc <- justConvert func

245+ optArgs <- T.traverse justConvert args

246+ Env.setTailCall hasTailCall

247+ return (Opt.Call optFunc optArgs)

248+

249+ Expr.If branches finally ->

250+ let

251+ crawlBranch (cond,branch) =

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

253+ in

254+ Opt.If

255+ <$> T.traverse crawlBranch branches

256+ <*> keepLooking finally

257+

258+ Expr.Let defs body ->

259+ do optDefs <- concat <$> T.traverse (optimizeDef Nothing) defs

260+ Opt.Let optDefs <$> keepLooking body

261+

262+ Expr.Case expr branches ->

263+ do optExpr <- optimizeExpr Nothing expr

264+ optBranches <- T.traverse (mapSnd (optimizeExpr context)) branches

265+ variantDict <- Env.getVariantDict

266+ Patterns.optimize variantDict region optExpr optBranches

267+

268+ Expr.Data name exprs ->

269+ Opt.Data name <$> T.traverse justConvert exprs

270+

271+ Expr.Access record field ->

272+ Opt.Access

273+ <$> justConvert record

274+ <*> pure field

275+

276+ Expr.Update record fields ->

277+ Opt.Update

278+ <$> justConvert record

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

280+

281+ Expr.Record fields ->

282+ Opt.Record

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

284+

285+ Expr.GLShader uid src gltipe ->

286+ pure (Opt.GLShader uid src gltipe)

287+

288+ Expr.Port impl ->

289+ Opt.Port <$>

290+ case impl of

291+ Expr.In name tipe ->

292+ pure (Expr.In name tipe)

293+

294+ Expr.Out name expr tipe ->

295+ (\e -> Expr.Out name e tipe) <$> justConvert expr

296+

297+ Expr.Task name expr tipe ->

298+ (\e -> Expr.Task name e tipe) <$> justConvert expr

299+

300+

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

302+mapSnd func (x, a) =

303+ (,) x <$> func a

304+

305+

306+-- DETECT TAIL CALL

307+

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

309+isTailCall context (A.A _ function) arity =

310+ case (context, function) of

311+ ( Just (ctxName, ctxArity, argNames), Expr.Var (Var.Canonical home name) ) ->

312+

313+ if name == ctxName && arity == ctxArity && Var.isLocalHome home then

314+ Just (name, argNames)

315+

316+ else

317+ Nothing

318+

319+ _ ->

320+ Nothing

321+

322+

323+-- DEPATTERN

324+-- given a pattern and an expression, push the actual pattern matching into the

325+-- expression as a case-expression if necessary. The pattern compiler will work

326+-- it out from there

327+

328+depattern :: P.CanonicalPattern -> Can.Expr -> Env.Optimizer (String, Can.Expr)

329+depattern canPattern@(A.A _ pattern) expr =

330+ let

331+ ann =

332+ A.A (error "the annotation added in 'depattern' should not be observed!")

333+

334+ caseExpr e branches =

335+ ann (Expr.Case e branches)

336+

337+ var name =

338+ ann (Expr.Var (Var.local name))

339+

340+ caseify =

341+ do name <- Env.freshName

342+ return

343+ ( name

344+ , caseExpr (var name) [ (canPattern, expr) ]

345+ )

346+ in

347+ case pattern of

348+ P.Var name ->

349+ return (name, expr)

350+

351+ P.Literal _ ->

352+ caseify

353+

354+ P.Record _ ->

355+ caseify

356+

357+ P.Anything ->

358+ do name <- Env.freshName

359+ return (name, expr)

360+

361+ P.Alias _ _ ->

362+ caseify

363+

364+ P.Data _ _ ->

365+ caseify

366+

367+

368+-- OPTIMIZE BINOPS

369+

370+optimizeBinop

371+ :: Context

372+ -> R.Region

373+ -> Var.Canonical

374+ -> Can.Expr

375+ -> Can.Expr

376+ -> Env.Optimizer Opt.Expr

377+optimizeBinop context region op leftExpr rightExpr =

378+ let

379+ ann = A.A region

380+ binop = ann (Expr.Binop op leftExpr rightExpr)

381+ in

382+ if op == forwardApply then

383+

384+ optimizeExpr context (collect id left forwardApply binop)

385+

386+ else if op == backwardApply then

387+

388+ optimizeExpr context (collect id right backwardApply binop)

389+

390+ else if op == forwardCompose then

391+

392+ do var <- Env.freshName

393+ let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))

394+ let body = collect makeRoot left forwardCompose binop

395+ optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))

396+

397+ else if op == backwardCompose then

398+

399+ do var <- Env.freshName

400+ let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))

401+ let body = collect makeRoot right backwardCompose binop

402+ optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))

403+

404+ else if op == Var.Canonical Var.BuiltIn "::" then

405+

406+ optimizeExpr context (ann (Expr.Data "::" [ leftExpr, rightExpr ]))

407+

408+ else

409+

410+ Opt.Binop op

411+ <$> optimizeExpr Nothing leftExpr

412+ <*> optimizeExpr Nothing rightExpr

413+

414+

415+-- left-associative ((x |> f) |> g)

416+forwardApply :: Var.Canonical

417+forwardApply =

418+ Var.inCore ["Basics"] "|>"

419+

420+

421+-- right-associative (g <| (f <| x))

422+backwardApply :: Var.Canonical

423+backwardApply =

424+ Var.inCore ["Basics"] "<|"

425+

426+

427+-- left-associative ((f >> g) >> h)

428+forwardCompose :: Var.Canonical

429+forwardCompose =

430+ Var.inCore ["Basics"] ">>"

431+

432+

433+-- right-associative (h << (g << f))

434+backwardCompose :: Var.Canonical

435+backwardCompose =

436+ Var.inCore ["Basics"] "<<"

437+

438+

439+type Assoc =

440+ Can.Expr -> Can.Expr -> (Can.Expr, Can.Expr)

441+

442+

443+left :: Assoc

444+left =

445+ flip (,)

446+

447+

448+right :: Assoc

449+right =

450+ (,)

451+

452+

453+collect :: (Can.Expr -> Can.Expr) -> Assoc -> Var.Canonical -> Can.Expr -> Can.Expr

454+collect makeRoot assoc desiredOp annExpr@(A.A ann expr) =

455+ case expr of

456+ Expr.Binop op leftExpr rightExpr | op == desiredOp ->

457+ let

458+ (func, arg) = assoc leftExpr rightExpr

459+ in

460+ A.A ann (Expr.App func (collect makeRoot assoc desiredOp arg))

461+

462+ _ ->

463+ makeRoot annExpr

src/Optimize/Cases.hsdeleted−266

@@ -1,266 +0,0 @@

1−module Optimize.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

2−

3−import Control.Applicative ((<$>))

4−import Control.Arrow (first)

5−import Control.Monad.State (State)

6−import qualified Control.Monad.State as State

7−import qualified Data.List as List

8−import Data.Maybe (fromMaybe)

9−

10−import qualified AST.Expression.General as Expr

11−import qualified AST.Expression.Optimized as Optimized

12−import qualified AST.Literal as Literal

13−import qualified AST.Pattern as P

14−import qualified AST.Variable as Var

15−import qualified Optimize.Substitute as S

16−import qualified Reporting.Annotation as A

17−

18−

19−-- MATCHES

20−

21−data Match

22− = Match String [Clause] Match

23− | Break

24− | Fail

25− | Other Optimized.Expr

26− | Seq [Match]

27− deriving (Show)

28−

29−

30−data Clause =

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

32− deriving (Show)

33−

34−

35−type Branch =

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

37−

38−

39−-- PUBLIC FUNCTIONS

40−

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

42−toMatch patterns =

43− do v <- newVar

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

45−

46−

47−newVar :: State Int String

48−newVar =

49− do n <- State.get

50− State.modify (+1)

51− return $ "_v" ++ show n

52−

53−

54−matchSubst :: [(String,String)] -> Match -> Match

55−matchSubst pairs match =

56− case match of

57− Break -> Break

58−

59− Fail -> Fail

60−

61− Seq ms ->

62− Seq (map (matchSubst pairs) ms)

63−

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

70−

71− Match n cs m ->

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

73− where

74− varSubst v = fromMaybe v (lookup v pairs)

75− clauseSubst (Clause c vs m) =

76− Clause c (map varSubst vs) (matchSubst pairs m)

77−

78−

79−-- BUILD MATCHES

80−

81−buildMatch :: [String] -> [Branch] -> Match -> State Int Match

82−buildMatch variables branches match =

83− case (variables, branches, match) of

84− ([], [], _) ->

85− return match

86−

87− ([], [([], expr)], Fail) ->

88− return $ Other expr

89−

90− ([], [([], expr)], Break) ->

91− return $ Other expr

92−

93− ([], _, _) ->

94− return $ Seq (map (Other . snd) branches ++ [match])

95−

96− (var:_, _, _)

97− | all isVar branches' -> matchVar variables branches' match

98− | all isCon branches' -> matchCon variables branches' match

99− | otherwise -> matchMix variables branches' match

100− where

101− branches' = map (dealias var) branches

102−

103−

104−dealias :: String -> Branch -> Branch

105−dealias _ ([], _) = noMatch "dealias"

106−dealias var branch@(p:ps, A.A ann e) =

107− case p of

108− A.A _ (P.Alias alias pattern) ->

109− ( pattern:ps

110− , A.A ann (S.subst alias (Expr.localVar var) e)

111− )

112−

113− _ ->

114− branch

115−

116−

117−isCon :: ([P.Pattern ann var], expr) -> Bool

118−isCon ([], _) = noMatch "isCon"

119−isCon (A.A _ pattern : _, _) =

120− case pattern of

121− P.Data _ _ -> True

122− P.Literal _ -> True

123− _ -> False

124−

125−

126−isVar :: ([P.Pattern ann var], expr) -> Bool

127−isVar p =

128− not (isCon p)

129−

130−

131−-- VARIABLE MATCHES

132−

133−matchVar :: [String] -> [Branch] -> Match -> State Int Match

134−matchVar [] _ _ = noMatch "matchVar"

135−matchVar (var:vars) branches match =

136− buildMatch vars (map subVar branches) match

137− where

138− subVar ([], _) = noMatch "matchVar.subVar"

139− subVar (A.A _ pattern : patterns, (A.A ann expr)) =

140− ( patterns

141− , A.A ann (subOnePattern pattern expr)

142− )

143− where

144− subOnePattern pattern expr =

145− case pattern of

146− P.Anything ->

147− expr

148−

149− P.Var x ->

150− S.subst x (Expr.localVar var) expr

151−

152− P.Record fields ->

153− let access = Expr.Access (A.A ann (Expr.localVar var))

154− in

155− foldr (\x -> S.subst x (access x)) expr fields

156−

157− _ ->

158− noMatch "matchVar.subVar"

159−

160−

161−-- CONSTRUCTOR MATCHES

162−

163−matchCon :: [String] -> [Branch] -> Match -> State Int Match

164−matchCon variables branches match =

165− case variables of

166− [] -> noMatch "matchCon"

167−

168− var : _vars ->

169− flip (Match var) match <$> mapM toClause caseGroups

170− where

171− caseGroups :: [[Branch]]

172− caseGroups =

173− List.groupBy branchEq (List.sortBy branchCmp branches)

174−

175− toClause :: [Branch] -> State Int Clause

176− toClause branches =

177− case head branches of

178− (A.A _ (P.Data name _) : _, _) ->

179− matchClause (Left name) variables branches Break

180−

181− (A.A _ (P.Literal lit) : _, _) ->

182− matchClause (Right lit) variables branches Break

183−

184− _ -> noMatch "matchCon"

185−

186−

187−matchClause

188− :: Either Var.Canonical Literal.Literal

189− -> [String]

190− -> [Branch]

191− -> Match

192− -> State Int Clause

193−matchClause _ [] _ _ = noMatch "matchClause"

194−matchClause c (_:vs) branches match =

195− do vs' <- getVars

196− Clause c vs' <$> buildMatch (vs' ++ vs) (map flatten branches) match

197− where

198− flatten ([], _) = noMatch "matchClause.flatten"

199− flatten (A.A _ pattern : patterns, expr) =

200− case pattern of

201− P.Data _ argPatterns ->

202− (argPatterns ++ patterns, expr)

203−

204− P.Literal _ ->

205− (patterns, expr)

206−

207− _ ->

208− noMatch "matchClause.flatten"

209−

210− getVars :: State Int [String]

211− getVars =

212− case head branches of

213− (A.A _ (P.Data _ argPatterns) : _, _) ->

214− State.forM argPatterns (const newVar)

215−

216− (A.A _ (P.Literal _) : _, _) ->

217− return []

218−

219− _ ->

220− noMatch "matchClause.getVars"

221−

222−

223−branchEq :: Branch -> Branch -> Bool

224−branchEq (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =

225− case (pattern, pattern') of

226− (P.Data name _, P.Data name' _) ->

227− name == name'

228−

229− (P.Literal lit, P.Literal lit') ->

230− lit == lit'

231−

232− (_, _) ->

233− noMatch "matchCon.branchEq"

234−

235−branchEq _ _ = noMatch "matchCon.branchEq"

236−

237−

238−branchCmp :: Branch -> Branch -> Ordering

239−branchCmp (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =

240− case (pattern, pattern') of

241− (P.Data name _, P.Data name' _) ->

242− compare name name'

243−

244− (P.Literal lit, P.Literal lit') ->

245− compare lit lit'

246−

247− (_, _) ->

248− noMatch "matchCon.branchCmp"

249−

250−branchCmp _ _ = noMatch "matchCon.branchCmp"

251−

252−

253−-- MIX MATCHES

254−

255−matchMix :: [String] -> [Branch] -> Match -> State Int Match

256−matchMix vs branches def =

257− State.foldM (flip $ buildMatch vs) def (reverse branchGroups)

258− where

259− branchGroups =

260− List.groupBy (\p1 p2 -> isCon p1 == isCon p2) branches

261−

262−

263−noMatch :: String -> a

264−noMatch name =

265− error $ "unexpected pattern in `" ++ name ++

266− "` function. Report a compiler issue to <https://github.com/elm-lang/Elm>."

src/Optimize/Environment.hsnew file+50

@@ -0,0 +1,50 @@

1+module Optimize.Environment

2+ ( Optimizer, run

3+ , Env

4+ , getVariantDict

5+ , getTailCall, setTailCall

6+ , freshName

7+ ) where

9+import qualified Control.Monad.State as State

10+

11+import qualified Optimize.Patterns.DecisionTree as DT

12+

13+

14+type Optimizer a =

15+ State.State Env a

16+

17+

18+run :: DT.VariantDict -> Optimizer a -> a

19+run variantDict optimizer =

20+ State.evalState optimizer (Env False 0 variantDict)

21+

22+

23+data Env = Env

24+ { _hasTailCall :: Bool

25+ , _uid :: Int

26+ , _variantDict :: DT.VariantDict

27+ }

28+

29+

30+getVariantDict :: Optimizer DT.VariantDict

31+getVariantDict =

32+ State.gets _variantDict

33+

34+

35+getTailCall :: Optimizer Bool

36+getTailCall =

37+ State.gets _hasTailCall

38+

39+

40+setTailCall :: Bool -> Optimizer ()

41+setTailCall bool =

42+ do env <- State.get

43+ State.put (env { _hasTailCall = bool })

44+

45+

46+freshName :: Optimizer String

47+freshName =

48+ do (Env htc uid vd) <- State.get

49+ State.put (Env htc (uid + 1) vd)

50+ return ("_p" ++ show uid)

src/Optimize/Patterns.hsnew file+124

@@ -0,0 +1,124 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Optimize.Patterns (optimize) where

4+import Control.Arrow (second)

5+import qualified Data.Map as Map

6+import Data.Map ((!))

7+import qualified Data.Maybe as Maybe

9+import qualified AST.Expression.Optimized as Opt

10+import qualified AST.Pattern as P

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

12+import qualified Optimize.Environment as Env

13+import qualified Optimize.Patterns.DecisionTree as DT

14+import qualified Reporting.Annotation as A

15+import qualified Reporting.Region as R

16+

17+

18+optimize

19+ :: DT.VariantDict

20+ -> R.Region

21+ -> Opt.Expr

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

23+ -> Env.Optimizer Opt.Expr

24+optimize variantDict region optExpr optBranches =

25+ let

26+ indexify index (pattern, branch) =

27+ ( (pattern, index)

28+ , (index, branch)

29+ )

30+ in

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

41+

42+ let (patterns, indexedBranches) =

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

44+

45+ let decisionTree =

46+ DT.compile variantDict patterns

47+

48+ tempName <- Env.freshName

49+

50+ return $

51+ Opt.Let

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

53+ (inlinedCase tempName decisionTree indexedBranches)

54+

55+

56+inlinedCase

57+ :: String

58+ -> DT.DecisionTree DT.Jump

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

60+ -> Opt.Expr

61+inlinedCase name decisionTree jumpTargets =

62+ let

63+ substitutionDict =

64+ gatherSubstitutions decisionTree

65+

66+ (jumps, sharedBranches) =

67+ unzip (map (toJumps substitutionDict) jumpTargets)

68+ in

69+ Opt.Case

70+ name

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

72+ (Maybe.catMaybes sharedBranches)

73+

74+

75+gatherSubstitutions

76+ :: DT.DecisionTree DT.Jump

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

78+gatherSubstitutions decisionTree =

79+ case decisionTree of

80+ DT.Decision _ edges fallback ->

81+ map snd edges

82+ |> maybe id (:) fallback

83+ |> map gatherSubstitutions

84+ |> Map.unionsWith (++)

85+

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

87+ Map.singleton target [substitutions]

88+

89+

90+toJumps

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

92+ -> (Int, Opt.Expr)

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

94+toJumps substitutionDict (target, branch) =

95+ case substitutionDict ! target of

96+ [substitutions] ->

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

98+ , Nothing

99+ )

100+

101+ substitutions : _ ->

102+ ( (target, Opt.Jump target)

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

104+ )

105+

106+ _ ->

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

108+

109+

110+inlineJumps

111+ :: Map.Map Int Opt.Jump

112+ -> DT.DecisionTree DT.Jump

113+ -> DT.DecisionTree Opt.Jump

114+inlineJumps jumpDict decisionTree =

115+ let

116+ go =

117+ inlineJumps jumpDict

118+ in

119+ case decisionTree of

120+ DT.Decision test edges fallback ->

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

122+

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

124+ DT.Match (jumpDict ! target)

src/Optimize/Patterns/DecisionTree.hsnew file+430

@@ -0,0 +1,430 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Optimize.Patterns.DecisionTree where

3+{- To learn more about how this works, definitely read through:

5+ "When Do Match-Compilation Heuristics Matter?"

7+by Kevin Scott and Norman Ramsey. The rough idea is that we start with a simple

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

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

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

11+as SML/NJ to get nice trees.

12+-}

13+

14+import Control.Arrow (second)

15+import Data.Function (on)

16+import qualified Data.List as List

17+import qualified Data.Map as Map

18+import qualified Data.Set as Set

19+import Data.Map ((!))

20+import qualified Data.Maybe as Maybe

21+

22+import qualified AST.Literal as L

23+import qualified AST.Pattern as P

24+import qualified AST.Variable as Var

25+import qualified Reporting.Annotation as A

26+

27+

28+type CPattern = P.CanonicalPattern

29+

30+

31+-- COMPILE CASES

32+

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

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

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

36+run.

37+

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

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

40+of this module though.

41+-}

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

43+compile variantDict rawBranches =

44+ let

45+ format (pattern, index) =

46+ Branch index [(Empty, pattern)]

47+ in

48+ toDecisionTree variantDict (map format rawBranches)

49+

50+

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

52+This helps us do a few optimizations:

53+

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

55+ Tuples are a common example of this.

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

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

58+ one we want

59+

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

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

62+we can use for these optimizations.

63+-}

64+type VariantDict =

65+ Map.Map Var.Canonical Int

66+

67+

68+-- DECISION TREES

69+

70+data DecisionTree a

71+ = Match a

72+ | Decision

73+ { _test :: Path

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

75+ , _default :: Maybe (DecisionTree a)

76+ }

77+

78+

79+data Jump = Jump

80+ { _result :: Int

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

82+ }

83+

84+

85+data Test

86+ = Constructor Var.Canonical

87+ | Literal L.Literal

88+ deriving (Eq, Ord)

89+

90+

91+data Path

92+ = Position Int Path

93+ | Field String Path

94+ | Empty

95+ | Alias

96+ deriving (Eq)

97+

98+

99+-- PATH HELPERS

100+

101+add :: Path -> Path -> Path

102+add path finalLink =

103+ case path of

104+ Empty ->

105+ finalLink

106+

107+ Alias ->

108+ error "nothing should be added to an alias path"

109+

110+ Position index subpath ->

111+ Position index (add subpath finalLink)

112+

113+ Field name subpath ->

114+ Field name (add subpath finalLink)

115+

116+

117+subPositions :: Path -> [CPattern] -> [(Path, CPattern)]

118+subPositions path patterns =

119+ zipWith

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

121+ [0..]

122+ patterns

123+

124+

125+-- ACTUALLY BUILD DECISION TREES

126+

127+data Branch =

128+ Branch

129+ { _goal :: Int

130+ , _patterns :: [(Path, CPattern)]

131+ }

132+

133+

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

135+toDecisionTree variantDict rawBranches =

136+ let

137+ branches =

138+ map (flattenPatterns variantDict) rawBranches

139+ in

140+ case checkForMatch branches of

141+ Just (goal, substitutions) ->

142+ Match (Jump goal substitutions)

143+

144+ Nothing ->

145+ let

146+ path =

147+ smallDefaults branches

148+

149+ relevantTests =

150+ testsAtPath path branches

151+

152+ allRawEdges =

153+ map (edgesFor path branches) relevantTests

154+

155+ (rawEdges, unexplored) =

156+ if isComplete variantDict relevantTests then

157+ ( init allRawEdges

158+ , snd (last allRawEdges)

159+ )

160+

161+ else

162+ ( allRawEdges

163+ , filter (isIrrelevantTo path) branches

164+ )

165+

166+ edges =

167+ map (second (toDecisionTree variantDict)) rawEdges

168+ in

169+ case (edges, unexplored) of

170+ ([(_tag, decisionTree)], []) ->

171+ decisionTree

172+

173+ (_, []) ->

174+ Decision path edges Nothing

175+

176+ (_, _) ->

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

178+

179+

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

181+isComplete variantDict tests =

182+ case head tests of

183+ Constructor name ->

184+ (variantDict ! name) == length tests

185+

186+ Literal (L.Boolean _) ->

187+ length tests == 2

188+

189+ _ ->

190+ False

191+

192+

193+

194+-- FLATTEN PATTERNS

195+

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

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

198+-}

199+flattenPatterns :: VariantDict -> Branch -> Branch

200+flattenPatterns variantDict (Branch goal pathPatterns) =

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

202+

203+

204+flatten :: VariantDict -> (Path, CPattern) -> [(Path, CPattern)]

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

206+ case pattern of

207+ P.Var _ ->

208+ [pathPattern]

209+

210+ P.Anything ->

211+ [pathPattern]

212+

213+ P.Alias alias realPattern ->

214+ [ (add path Alias, A.A ann (P.Var alias))

215+ , (path, realPattern)

216+ ]

217+

218+ P.Record _ ->

219+ [pathPattern]

220+

221+ P.Data tag patterns ->

222+ if variantDict ! tag == 1 then

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

224+

225+ else

226+ [pathPattern]

227+

228+ P.Literal _ ->

229+ [pathPattern]

230+

231+

232+-- SUCCESSFULLY MATCH

233+

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

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

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

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

238+-}

239+checkForMatch :: [Branch] -> Maybe (Int, [(String, Path)])

240+checkForMatch branches =

241+ case branches of

242+ Branch goal patterns : _ ->

243+ (,) goal `fmap` concat `fmap` mapM getSubstitution patterns

244+

245+ _ ->

246+ Nothing

247+

248+

249+getSubstitution :: (Path, CPattern) -> Maybe [(String, Path)]

250+getSubstitution (path, A.A _ pattern) =

251+ case pattern of

252+ P.Var x ->

253+ Just [(x, path)]

254+

255+ P.Anything ->

256+ Just []

257+

258+ P.Alias _ _ ->

259+ error "aliases should never reach 'getSubstitution' function"

260+

261+ P.Record fields ->

262+ Just (map (\name -> (name, add path (Field name Empty))) fields)

263+

264+ P.Data _ _ ->

265+ Nothing

266+

267+ P.Literal _ ->

268+ Nothing

269+

270+

271+-- FIND RELEVANT TESTS

272+

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

274+testsAtPath selectedPath branches =

275+ let

276+ allTests =

277+ Maybe.mapMaybe (testAtPath selectedPath) branches

278+

279+ skipVisited test curr@(uniqueTests, visitedTests) =

280+ if Set.member test visitedTests then

281+ curr

282+ else

283+ ( test : uniqueTests

284+ , Set.insert test visitedTests

285+ )

286+ in

287+ fst (foldr skipVisited ([], Set.empty) allTests)

288+

289+

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

291+testAtPath selectedPath (Branch _ pathPatterns) =

292+ case List.lookup selectedPath pathPatterns of

293+ Nothing ->

294+ Nothing

295+

296+ Just (A.A _ pattern) ->

297+ case pattern of

298+ P.Data name _ ->

299+ Just (Constructor name)

300+

301+ P.Literal lit ->

302+ Just (Literal lit)

303+

304+ P.Var _ ->

305+ Nothing

306+

307+ P.Alias _ _ ->

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

309+

310+ P.Anything ->

311+ Nothing

312+

313+ P.Record _ ->

314+ Nothing

315+

316+

317+-- BUILD EDGES

318+

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

320+edgesFor path branches test =

321+ ( test

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

323+ )

324+

325+

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

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

328+ case extract path pathPatterns of

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

330+ case pattern of

331+ P.Data name patterns ->

332+ if test == Constructor name then

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

334+

335+ else

336+ Nothing

337+

338+ P.Literal lit ->

339+ if test == Literal lit then

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

341+

342+ else

343+ Nothing

344+

345+ _ ->

346+ Just branch

347+

348+ _ ->

349+ Just branch

350+

351+

352+extract

353+ :: Path

354+ -> [(Path, CPattern)]

355+ -> Maybe ([(Path, CPattern)], CPattern, [(Path, CPattern)])

356+extract selectedPath pathPatterns =

357+ case pathPatterns of

358+ [] ->

359+ Nothing

360+

361+ first@(path, pattern) : rest ->

362+ if path == selectedPath then

363+ Just ([], pattern, rest)

364+

365+ else

366+ case extract selectedPath rest of

367+ Nothing ->

368+ Nothing

369+

370+ Just (start, foundPattern, end) ->

371+ Just (first : start, foundPattern, end)

372+

373+

374+-- FIND IRRELEVANT BRANCHES

375+

376+isIrrelevantTo :: Path -> Branch -> Bool

377+isIrrelevantTo selectedPath (Branch _ pathPatterns) =

378+ case List.lookup selectedPath pathPatterns of

379+ Nothing ->

380+ True

381+

382+ Just pattern ->

383+ not (needsTests pattern)

384+

385+

386+needsTests :: CPattern -> Bool

387+needsTests (A.A _ pattern) =

388+ case pattern of

389+ P.Var _ ->

390+ False

391+

392+ P.Anything ->

393+ False

394+

395+ P.Alias _ _ ->

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

397+

398+ P.Record _ ->

399+ False

400+

401+ P.Data _ _ ->

402+ True

403+

404+ P.Literal _ ->

405+ True

406+

407+

408+-- PATH PICKING HEURISTICS

409+

410+smallDefaults :: [Branch] -> Path

411+smallDefaults branches =

412+ let

413+ allPaths =

414+ Maybe.mapMaybe isChoicePath (concatMap _patterns branches)

415+

416+ weightedPaths =

417+ map (\path -> (path, length (filter (isIrrelevantTo path) branches))) allPaths

418+ in

419+ fst (List.minimumBy (compare `on` snd) weightedPaths)

420+

421+

422+isChoicePath :: (Path, CPattern) -> Maybe Path

423+isChoicePath (path, pattern) =

424+ if needsTests pattern then

425+ Just path

426+ else

427+ Nothing

428+

429+

430+-- smallBranchingFactor :: [Branch] -> Path

src/Optimize/TailCalls.hsdeleted−235

@@ -1,235 +0,0 @@

1−module Optimize.TailCalls where

2−

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

8−

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

72− lambda x e =

73− A.A () (Lambda x e)

74−

75− facts =

76− Opt.Facts

77− (if isTailCall then fmap fst context else Nothing)

78− (Can.dependencies canonFacts)

79− in

80− Opt.Definition

81− facts

82− (removeAnnotations pattern)

83− (foldr lambda optExpr (map removeAnnotations args))

84−

85−

86−-- CONVERT EXPRESSIONS

87−

88−type Context = Maybe (String, Int)

89−

90−

91−findTailCalls :: Context -> Can.Expr -> Result Opt.Expr

92−findTailCalls context annExpr@(A.A _ expression) =

93− let

94− keepLooking =

95− findTailCalls context

96− -- this *might* find a tail call, use this when something is a potential

97− -- tail call

98−

99− justConvert =

100− findTailCalls Nothing

101− -- this will never find tail calls, use this when you are working with

102− -- expressions that cannot be turned into tail calls

103− in

104− A.A () <$>

105− case expression of

106− Literal lit ->

107− pure (Literal lit)

108−

109− Var name ->

110− pure (Var name)

111−

112− Range lowExpr highExpr ->

113− Range

114− <$> justConvert lowExpr

115− <*> justConvert highExpr

116−

117− ExplicitList elements ->

118− ExplicitList

119− <$> T.traverse justConvert elements

120−

121− Binop op leftExpr rightExpr ->

122− Binop op

123− <$> justConvert leftExpr

124− <*> justConvert rightExpr

125−

126− Lambda pattern body ->

127− Lambda (removeAnnotations pattern) <$> justConvert body

128−

129− App _ _ ->

130− let

131− (func:args) =

132− Expr.collectApps annExpr

133−

134− isTailCall =

135− case (context, func) of

136− ( Just (name, argNum), A.A _ (Var (Var.Canonical Var.Local name')) ) ->

137− name == name' && length args == argNum

138− ( Just (name, argNum), A.A _ (Var (Var.Canonical (Var.TopLevel _) name')) ) ->

139− name == name' && length args == argNum

140− _ ->

141− False

142−

143− (Result _ (A.A _ optFunc)) =

144− justConvert func

145−

146− (Result _ optArgs) =

147− T.traverse justConvert args

148−

149− apply f arg =

150− App (A.A () f) arg

151− in

152− Result isTailCall (List.foldl' apply optFunc optArgs)

153−

154−

155− If branches finally ->

156− let

157− crawlBranch (cond,branch) =

158− (,) <$> justConvert cond <*> keepLooking branch

159− in

160− If

161− <$> T.traverse crawlBranch branches

162− <*> keepLooking finally

163−

164− Let defs body ->

165− let

166− optDefs = map detectTailRecursion defs

167− in

168− Let optDefs <$> keepLooking body

169−

170− Case expr cases ->

171− let

172− preppedCases =

173− map (first removeAnnotations) cases

174− in

175− Case

176− <$> justConvert expr

177− <*> T.traverse (mapSnd keepLooking) preppedCases

178−

179− Data name exprs ->

180− Data name <$> T.traverse justConvert exprs

181−

182− Access record field ->

183− Access

184− <$> justConvert record

185− <*> pure field

186−

187− Update record fields ->

188− Update

189− <$> justConvert record

190− <*> T.traverse (mapSnd justConvert) fields

191−

192− Record fields ->

193− Record

194− <$> T.traverse (mapSnd justConvert) fields

195−

196− GLShader uid src gltipe ->

197− pure (GLShader uid src gltipe)

198−

199− Port impl ->

200− Port <$>

201− case impl of

202− In name tipe ->

203− pure (In name tipe)

204−

205− Out name expr tipe ->

206− (\e -> Out name e tipe) <$> justConvert expr

207−

208− Task name expr tipe ->

209− (\e -> Task name e tipe) <$> justConvert expr

210−

211− Crash details ->

212− pure (Crash details)

213−

214−

215−removeAnnotations :: P.CanonicalPattern -> P.Optimized

216−removeAnnotations (A.A _ pattern) =

217− A.A () $

218− case pattern of

219− P.Var x ->

220− P.Var x

221−

222− P.Literal lit ->

223− P.Literal lit

224−

225− P.Record fields ->

226− P.Record fields

227−

228− P.Anything ->

229− P.Anything

230−

231− P.Alias alias realPattern ->

232− P.Alias alias (removeAnnotations realPattern)

233−

234− P.Data name patterns ->

235− P.Data name (map removeAnnotations patterns)

src/Reporting/Crash.hsdeleted−20

@@ -1,20 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Reporting.Crash where

3−

4−import qualified Reporting.Region as R

5−

6−

7−data Details

8− = IncompleteMultiIf R.Region

9− | IncompletePatternMatch R.Region

10− deriving (Show)

11−

12−

13−summary :: Details -> String

14−summary details =

15− case details of

16− IncompleteMultiIf _ ->

17− "incomplete-multi-if"

18−

19− IncompletePatternMatch _ ->

20− "incomplete-pattern-match"

src/Type/Constrain/Expression.hs−3

@@ -168,9 +168,6 @@ constrain env annotatedExpr@(A.A region expression) tipe =

168168 E.Task _ expr _ ->

169169 constrain env expr tipe

170170

171− E.Crash _ ->

172− return CTrue

173−

174171

175172-- CONSTRAIN APP

176173

src/Validate.hs−3

@@ -254,9 +254,6 @@ expression (A.A ann sourceExpression) =

254254 do expr' <- expression expr

255255 return (Task name expr' tipe)

256256

257− Crash details ->

258− return (Crash details)

259−

260257

261258second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

262259second (value, expr) =