2d29699 · elk · git.iko.soy

git.iko.soy/elk

Make separate type for the optimized AST

This allows us to mess with the representation of various language constructs such that they are easier to work with during code gen. Notable examples include: * Optimizing all patterns out of the representation * Splitting `App` into `Call` and `TailCall` which list all arguments at once * Turning `Lambda` into `Function` which lists all arguments at once * Revamping `Case` to handle the new decision trees * Adding `Crash` which will eventually hold region info * Adding the `DataAccess` operation which is not in the source syntax

commit2d296997444e6853cba4547240e3e1fd33f31212 authorEvan Czaplicki <info@elm-lang.org> dateFri 4 Sep 2015, 02:33 (11 years ago) parent92dc057

9 files changed+449−399

compare with master

unifiedsplit

src/AST/Expression/Optimized.hs+32−20 src/AST/Module.hs+1−1 src/AST/Pattern.hs−4 src/AST/Variable.hs+16 src/Generate/JavaScript.hs+78−201 src/Generate/JavaScript/Variable.hs+18−6 src/Optimize.hs+2−12 src/Optimize/Cases.hs+18−26 src/Optimize/TailCalls.hs+284−129

src/AST/Expression/Optimized.hs+32−20

@@ -1,36 +1,48 @@

11{-# OPTIONS_GHC -Wall #-}

22module AST.Expression.Optimized

3− ( Expr, Expr'

3+ ( Expr(..)

44 , Def(..)

5− , Facts(..), dummyFacts

5+ , Facts(..)

66 ) where

8+import qualified Data.Map as Map

810import qualified AST.Expression.General as General

9−import qualified AST.Pattern as Pattern

11+import qualified AST.Literal as Literal

12+import qualified AST.Module.Name as ModuleName

1013import qualified AST.Type as Type

1114import 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

15+import qualified Optimize.Cases as PM

16+

17+

18+data Expr

19+ = Literal Literal.Literal

20+ | Var Var.Canonical

21+ | Range Expr Expr

22+ | ExplicitList [Expr]

23+ | Binop Var.Canonical Expr Expr

24+ | Function [String] Expr

25+ | Call Expr [Expr]

26+ | TailCall String [String] [Expr]

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

28+ | Let [Def] Expr

29+ | Case Expr (PM.DecisionTree Int) (Map.Map Int Expr)

30+ | Data String [Expr]

31+ | DataAccess Expr Int

32+ | Access Expr String

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

34+ | Record [(String, Expr)]

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

36+ | GLShader String String Literal.GLShaderTipe

37+ | Crash

2038

2139

2240data Def

23− = Definition Facts Pattern.Optimized Expr

24− deriving (Show)

41+ = Def Facts String Expr

42+ | TailDef Facts String [String] Expr

2543

2644

2745data Facts = Facts

28− { tailRecursionDetails :: Maybe String

46+ { home :: Maybe ModuleName.Canonical

2947 , dependencies :: [Var.TopLevel]

3048 }

31− deriving (Show)

32−

33−

34−dummyFacts :: Facts

35−dummyFacts =

36− Facts Nothing []

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/Generate/JavaScript.hs+78−201

@@ -5,38 +5,29 @@ import Control.Arrow (first, second, (***))

55import Control.Monad.State as State

66import qualified Data.List as List

77import qualified Data.Map as Map

8−import qualified Data.Maybe as Maybe

98import Language.ECMAScript3.PrettyPrint as ES

109import Language.ECMAScript3.Syntax

1110import qualified Text.PrettyPrint.Leijen as PP

1211

13−import AST.Expression.General as Expr

14−import qualified AST.Expression.Optimized as Opt

15−import qualified AST.Helpers as Help

12+import qualified AST.Expression.General as Expr

13+import AST.Expression.Optimized as Opt

1614import AST.Literal

1715import qualified AST.Module as Module

1816import qualified AST.Module.Name as ModuleName

19−import qualified AST.Pattern as P

2017import qualified AST.Variable as Var

2118import Generate.JavaScript.Helpers as Help

2219import qualified Generate.JavaScript.BuiltIn as BuiltIn

23−import qualified Generate.JavaScript.Crash as Crash

2420import qualified Generate.JavaScript.Literal as Literal

2521import qualified Generate.JavaScript.Port as Port

2622import qualified Generate.JavaScript.Variable as Var

27−import qualified Optimize.Cases as Case

28−import qualified Reporting.Annotation as A

29−import qualified Reporting.Crash as Crash

23+import qualified Optimize.Cases as PM

3024

3125

3226generate :: Module.Optimized -> String

33−generate module_ =

27+generate definitions =

3428 let

35− (definitions, _) =

36− flattenLets [] (Module.program (Module.body module_))

37−

3829 stmts =

39− concat (State.evalState (mapM defToStatements definitions) 0)

30+ State.evalState (mapM generateDef definitions) 0

4031 in

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

4233

@@ -122,7 +113,7 @@ exprToJsExpr tcc canonicalExpr =

122113

123114

124115exprToCode :: TailCallContext -> Opt.Expr -> State Int Code

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

116+exprToCode tcc expr =

126117 case expr of

127118 Var var ->

128119 jsExpr $ Var.canonical var

@@ -172,11 +163,33 @@ exprToCode tcc annotatedExpr@(A.A _ expr) =

172163 Binop op leftExpr rightExpr ->

173164 binop op leftExpr rightExpr

174165

175− Lambda _ _ ->

176− generateFunction (Expr.collectLambdas annotatedExpr)

166+ Function args body ->

167+ generateFunction args body

177168

178− App _ _ ->

179− generateApplication tcc annotatedExpr

169+ Call func args ->

170+ let

171+ arity = length args

172+ aN = "A" ++ show arity

173+ in

174+ do jsFunc <- toJsExpr func

175+ jsArgs <- mapM toJsExpr args

176+ jsExpr $

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

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

179+ else

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

181+

182+ TailCall name argNames args ->

183+ let

184+ reassign name tempName =

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

186+ in

187+ do args' <- mapM toJsExpr args

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

189+ jsBlock $

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

191+ : zipWith reassign argNames tempNames

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

180193

181194 Let defs body ->

182195 generateLet tcc defs body

@@ -184,8 +197,8 @@ exprToCode tcc annotatedExpr@(A.A _ expr) =

184197 If branches finally ->

185198 generateIf tcc branches finally

186199

187− Case expr branches ->

188− generateCase tcc expr branches

200+ Case expr decisionTree branches ->

201+ generateCase tcc expr decisionTree branches

189202

190203 ExplicitList elements ->

191204 do jsElements <- mapM toJsExpr elements

@@ -199,43 +212,45 @@ exprToCode tcc annotatedExpr@(A.A _ expr) =

199212 fields =

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

201214

215+ DataAccess dataExpr index ->

216+ do jsDataExpr <- toJsExpr dataExpr

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

218+

202219 GLShader _uid src _tipe ->

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

204221

205222 Port impl ->

206223 case impl of

207− In name portType ->

224+ Expr.In name portType ->

208225 jsExpr (Port.inbound name portType)

209226

210− Out name expr portType ->

227+ Expr.Out name expr portType ->

211228 do expr' <- toJsExpr expr

212229 jsExpr (Port.outbound name expr' portType)

213230

214− Task name expr portType ->

231+ Expr.Task name expr portType ->

215232 do expr' <- toJsExpr expr

216233 jsExpr (Port.task name expr' portType)

217234

218− Crash details ->

219− jsExpr $ Crash.crash details

235+ Crash ->

236+ error "TODO"

220237

221238

222239-- FUNCTIONS

223240

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

225−generateFunction (args, initialBody) =

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

227− code <- generateLet Nothing patternDefs initialBody

228− jsExpr (generateFunctionWithArity argVars code)

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

242+generateFunction args body =

243+ do code <- exprToCode Nothing body

244+ jsExpr (generateFunctionWithArity args code)

229245

230246

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

232−generateTailFunction name (args, initialBody) =

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

234− label <- Id () <$> Var.fresh

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

236− let whileLoop =

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

238− return (generateFunctionWithArity argVars whileLoop)

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

248+generateTailFunction name args body =

249+ do code <- exprToCode Nothing body

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

251+ LabelledStmt ()

252+ (Id () name)

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

239254

240255

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

@@ -256,81 +271,6 @@ generateFunctionWithArity args code =

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

257272

258273

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

260−destructuredArgs args =

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

262− return (argVars, Maybe.catMaybes maybePatternDefs)

263−

264−

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

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

267− case pat of

268− P.Var x ->

269− return (Var.safe x, Nothing)

270−

271− _ ->

272− do arg <- Var.fresh

273− return

274− ( arg

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

276− )

277−

278−

279−-- APPLICATIONS

280−

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

282−generateApplication tcc expr =

283− let

284− (func:args) =

285− Expr.collectApps expr

286−

287− arity =

288− length args

289−

290− reassign name tempName =

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

292−

293− aN =

294− "A" ++ show arity

295− in

296− case isTailCall tcc func arity of

297− Just (argNames, label) ->

298− do args' <- mapM toJsExpr args

299− tempNames <- mapM (\_ -> Var.fresh) args

300− jsBlock $

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

302− : zipWith reassign argNames tempNames

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

304−

305− _ ->

306− do func' <- toJsExpr func

307− args' <- mapM toJsExpr args

308− jsExpr $

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

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

311− else

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

313−

314−

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

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

317− case (func, tcc) of

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

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

320− Just (tcArgs, tcLabel)

321− else

322− Nothing

323−

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

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

326− Just (tcArgs, tcLabel)

327− else

328− Nothing

329−

330− _ ->

331− Nothing

332−

333−

334274-- LET EXPRESSIONS

335275

336276generateLet

@@ -338,20 +278,12 @@ generateLet

338278 -> [Opt.Def]

339279 -> Opt.Expr

340280 -> State Int Code

341−generateLet tcc givenDefs givenBody =

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

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

281+generateLet tcc defs body =

282+ do stmts <- mapM generateDef defs

344283 code <- exprToCode tcc body

345284 jsBlock (stmts ++ toStatementList code)

346285

347286

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

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

350− case expr of

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

352− _ -> (defs, lexpr)

353−

354−

355287-- GENERATE IFS

356288

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

@@ -396,13 +328,13 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

396328 case unvisitedBranches of

397329 [] ->

398330 case finally of

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

331+ If subBranches subFinally ->

400332 crushIfsHelp visitedBranches subBranches subFinally

401333

402334 _ ->

403335 (reverse visitedBranches, finally)

404336

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

337+ (Literal (Boolean True), branch) : _ ->

406338 crushIfsHelp visitedBranches [] branch

407339

408340 visiting : unvisited ->

@@ -412,84 +344,29 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

412344

413345-- DEFINITIONS

414346

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

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

417− case Opt.tailRecursionDetails facts of

418− Just name ->

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

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

421−

422− Nothing ->

423− defToStatementsHelp facts pattern =<< toJsExpr expr

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

348+generateDef def =

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

350+ case def of

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

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

424353

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

355+ (,,) home name <$> toJsExpr body

425356

426−defToStatementsHelp

427− :: Opt.Facts

428− -> P.Optimized

429− -> Expression ()

430− -> State Int [Statement ()]

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

432− let

433− define x =

434− varDecl x jsExpr

435− in

436− case pattern of

437− P.Var x ->

438− if Help.isOp x then

439− let

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

441− in

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

443− else

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

445−

446− P.Record fields ->

447− let

448− setField name =

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

450− in

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

452−

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

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

455− where

456− vars = getVars patterns

457− getVars patterns =

458− case patterns of

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

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

461− [] ->

462− Just []

463− _ ->

464− Nothing

465−

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

467− setup vars

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

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

470−

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

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

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

474−

475− _ ->

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

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

478− where

479− vars = P.boundVarList annPattern

480− mkVar = A.A () . localVar

481− toDef y =

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

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

484− in

485− defToStatements (Opt.Definition facts pat expr)

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

486358

487359

488360-- CASE EXPRESSIONS

489361

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

491−generateCase tcc expr branches =

492− error "TODO" tcc expr branches

362+generateCase

363+ :: TailCallContext

364+ -> Opt.Expr

365+ -> PM.DecisionTree Int

366+ -> Map.Map Int Opt.Expr

367+ -> State Int Code

368+generateCase tcc expr decisionTree branches =

369+ error "TODO" tcc expr decisionTree branches

493370

494371

495372-- BINARY OPERATORS

@@ -501,7 +378,7 @@ binop

501378 -> State Int Code

502379binop func left right

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

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

381+ toCode (Data "::" [left,right])

505382

506383 | func == forwardCompose =

507384 compose (collectLeftAssoc forwardCompose left right)

@@ -629,7 +506,7 @@ collectRightAssoc desiredOp left right =

629506collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

630507collectRightAssocHelp desiredOp exprList expr =

631508 case expr of

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

509+ Binop op left right | op == desiredOp ->

633510 collectRightAssocHelp desiredOp (left : exprList) right

634511

635512 _ ->

@@ -645,7 +522,7 @@ collectLeftAssoc desiredOp left right =

645522collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

646523collectLeftAssocHelp desiredOp exprList expr =

647524 case expr of

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

525+ Binop op left right | op == desiredOp ->

649526 collectLeftAssocHelp desiredOp (right : exprList) left

650527

651528 _ ->

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

@@ -1,4 +1,4 @@

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

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

33import qualified Control.Monad.State as State

44import qualified Data.List as List

@@ -21,6 +21,18 @@ fresh =

2121 return ("_v" ++ show n)

2222

2323

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+

2436-- INSTANTIATE VARIABLES

2537

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

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

3951 name

4052

4153 Var.TopLevel moduleName ->

42− canonicalName moduleName name

54+ canonicalPrefix moduleName name

4355

4456 Var.BuiltIn ->

4557 name

4658

4759 Var.Module moduleName ->

48− canonicalName moduleName name

60+ canonicalPrefix moduleName name

4961

5062

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

52−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 =

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

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

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

56− ++ '$' : name

68+ ++ '$' : safe name

5769

5870

5971swap :: Char -> Char -> Char -> Char

src/Optimize.hs+2−12

@@ -5,15 +5,5 @@ import qualified Optimize.TailCalls as TC

77optimize :: 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 }

8+optimize =

9+ TC.optimize

src/Optimize/Cases.hs+18−26

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Optimize.Cases where

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

@@ -10,7 +11,6 @@ explains this extraordinarily well! We are currently using the same heuristics

1011as SML/NJ to get nice trees.

1112-}

1213

13−

1414import Control.Arrow (second)

1515import Data.Function (on)

1616import qualified Data.List as List

@@ -18,13 +18,15 @@ import qualified Data.Map as Map

1818import Data.Map ((!))

1919import qualified Data.Maybe as Maybe

2020

21−import qualified AST.Expression.Optimized as Opt

2221import qualified AST.Literal as L

2322import qualified AST.Pattern as P

2423import qualified AST.Variable as Var

2524import qualified Reporting.Annotation as A

2625

2726

27+type CPattern = P.CanonicalPattern

28+

29+

2830-- COMPILE CASES

2931

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

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

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

3739of this module though.

3840-}

39−compile

40− :: VariantDict

41− -> [(P.Optimized, Opt.Expr)]

42− -> (DecisionTree Int, Map.Map Int Opt.Expr)

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

4342compile variantDict rawBranches =

4443 let

45− format index (pattern, expr) =

46− ( Branch index [(Empty, pattern)]

47− , (index, expr)

48− )

49−

50− (branches, resultList) =

51− unzip (zipWith format [0..] rawBranches)

44+ format (pattern, index) =

45+ Branch index [(Empty, pattern)]

5246 in

53− ( toDecisionTree variantDict branches

54− , Map.fromList resultList

55− )

47+ toDecisionTree variantDict (map format rawBranches)

5648

5749

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

@@ -81,8 +73,8 @@ data DecisionTree a

8173 , _default :: Maybe (DecisionTree a)

8274 }

8375 | Match

84− { result :: a

85− , substitutions :: Map.Map String Path

76+ { _result :: a

77+ , _substitutions :: Map.Map String Path

8678 }

8779

8880

@@ -118,7 +110,7 @@ add path finalLink =

118110 Field name (add subpath finalLink)

119111

120112

121−subPositions :: Path -> [P.Optimized] -> [(Path, P.Optimized)]

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

122114subPositions path patterns =

123115 zipWith

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

@@ -131,7 +123,7 @@ subPositions path patterns =

131123data Branch =

132124 Branch

133125 { _goal :: Int

134− , _patterns :: [(Path, P.Optimized)]

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

135127 }

136128

137129

@@ -205,7 +197,7 @@ flattenPatterns variantDict (Branch goal pathPatterns) =

205197 Branch goal (concatMap (flatten variantDict) pathPatterns)

206198

207199

208−flatten :: VariantDict -> (Path, P.Optimized) -> [(Path, P.Optimized)]

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

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

210202 case pattern of

211203 P.Var _ ->

@@ -251,7 +243,7 @@ checkForMatch branches =

251243 Nothing

252244

253245

254−getSubstitution :: (Path, P.Optimized) -> Maybe [(String, Path)]

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

255247getSubstitution (path, A.A _ pattern) =

256248 case pattern of

257249 P.Var x ->

@@ -336,8 +328,8 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =

336328

337329extract

338330 :: Path

339− -> [(Path, P.Optimized)]

340− -> Maybe ([(Path, P.Optimized)], P.Optimized, [(Path, P.Optimized)])

331+ -> [(Path, CPattern)]

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

341333extract selectedPath pathPatterns =

342334 case pathPatterns of

343335 [] ->

@@ -368,7 +360,7 @@ isIrrelevantTo selectedPath (Branch _ pathPatterns) =

368360 not (needsTests pattern)

369361

370362

371−needsTests :: P.Optimized -> Bool

363+needsTests :: CPattern -> Bool

372364needsTests (A.A _ pattern) =

373365 case pattern of

374366 P.Var _ ->

@@ -404,7 +396,7 @@ smallDefaults branches =

404396 fst (List.minimumBy (compare `on` snd) weightedPaths)

405397

406398

407−isChoicePath :: (Path, P.Optimized) -> Maybe Path

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

408400isChoicePath (path, pattern) =

409401 if needsTests pattern then

410402 Just path

src/Optimize/TailCalls.hs+284−129

@@ -1,46 +1,64 @@

1−module Optimize.TailCalls where

1+module Optimize.TailCalls (optimize) where

33import Control.Applicative

4−import Control.Arrow (first)

54import qualified Control.Monad as M

6−import qualified Data.List as List

5+import qualified Control.Monad.State as State

6+import qualified Data.Map as Map

77import qualified Data.Traversable as T

9−import AST.Expression.General as Expr

9+import qualified AST.Expression.General as Expr

1010import qualified AST.Expression.Canonical as Can

1111import qualified AST.Expression.Optimized as Opt

12+import qualified AST.Module as Module

13+import qualified AST.Module.Name as ModuleName

1214import qualified AST.Pattern as P

1315import qualified AST.Variable as Var

16+import qualified Optimize.Cases as Cases

1417import qualified Reporting.Annotation as A

1518

1619

1720-- OPTIMIZE FOR TAIL CALLS

1821

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

20−optimize expression =

21− let

22− (Result _ optExpr) =

23− findTailCalls Nothing expression

24− in

25− optExpr

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

23+optimize module_ =

24+ let

25+ home =

26+ Module.name module_

27+

28+ (defs, _) =

29+ flattenLets [] (Module.program (Module.body module_))

30+ in

31+ State.evalState

32+ (concat <$> mapM (definition (Just home)) defs)

33+ (Env False 0)

2634

2735

28−-- TRACKER TO THREAD FINDINGS THROUGH TRAVERSAL

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

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

38+ case expr of

39+ Expr.Let ds body ->

40+ flattenLets (defs ++ ds) body

41+

42+ _ ->

43+ (defs, annExpr)

44+

2945

30−data Result a = Result Bool a

46+-- TRACKER TO THREAD FINDINGS THROUGH TRAVERSAL

3147

48+type Optimizer a =

49+ State.State Env a

3250

33−instance M.Functor Result where

34− fmap func (Result hasTailCall value) =

35− Result hasTailCall (func value)

3651

52+data Env = Env

53+ { _hasTailCall :: Bool

54+ , _uid :: Int

55+ }

3756

38−instance Applicative Result where

39− pure value =

40− Result False value

4157

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

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

58+setTailCall :: Bool -> Optimizer ()

59+setTailCall bool =

60+ do uid <- State.gets _uid

61+ State.put (Env bool uid)

4462

4563

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

@@ -50,45 +68,132 @@ mapSnd func (x, a) =

5068

5169-- CONVERT DEFINITIONS

5270

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

54−detectTailRecursion (Can.Definition canonFacts pattern expression _) =

55− let

56− (args, body) =

57− Expr.collectLambdas expression

71+definition :: Maybe ModuleName.Canonical -> Can.Def -> Optimizer [Opt.Def]

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

73+ let

74+ (args, rawBody) =

75+ Expr.collectLambdas expression

76+ in

77+ case (ptrn, args) of

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

79+

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

81+ State.put (Env False uid)

82+

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

84+

85+ (Env isTailCall uid') <- State.get

86+ State.put (Env htc uid')

87+

88+ let facts = Opt.Facts home deps

5889

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)

90+ return $

91+ if isTailCall then

6592

66− _ ->

67− Nothing

93+ [ Opt.TailDef facts name args body ]

6894

69− (Result isTailCall optExpr) =

70− findTailCalls context body

95+ else

7196

72− lambda x e =

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

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

7498

75− facts =

76− Opt.Facts

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

78− (Can.dependencies canonFacts)

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

100+

101+ do hasTailCall <- State.gets _hasTailCall

102+ body <- findTailCalls Nothing rawBody

103+ setTailCall hasTailCall

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

105+

106+ (_, []) ->

107+

108+ do name <- freshName

109+ optBody <- findTailCalls Nothing rawBody

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

111+ return (optDef : patternToDefs home name pattern)

112+

113+ _ ->

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

115+

116+

117+-- OPTIMIZE FUNCTION

118+

119+optimizeFunction

120+ :: Maybe String

121+ -> [P.CanonicalPattern]

122+ -> Can.Expr

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

124+optimizeFunction maybeName patterns givenBody =

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

126+ optBody <- findTailCalls (makeContext argNames =<< maybeName) body

127+ return (argNames, optBody)

128+

129+

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

131+makeContext argNames name =

132+ Just (name, length argNames, argNames)

133+

134+

135+depatternArgs

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

137+ -> P.CanonicalPattern

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

139+depatternArgs (names, rawExpr) ptrn =

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

141+ return (name : names, expr)

142+

143+

144+patternToDefs

145+ :: Maybe ModuleName.Canonical

146+ -> String

147+ -> P.CanonicalPattern

148+ -> [Opt.Def]

149+patternToDefs home rootName pattern =

150+ let

151+ (deps, rootExpr) =

152+ case home of

153+ Nothing ->

154+ ( []

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

156+ )

157+

158+ Just moduleName ->

159+ ( [ Var.TopLevelVar moduleName rootName ]

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

161+ )

162+

163+ toDef (name, accessExpr) =

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

79165 in

80− Opt.Definition

81− facts

82− (removeAnnotations pattern)

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

166+ map toDef (substitutions rootExpr pattern)

167+

168+

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

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

171+ case pattern of

172+ P.Var name ->

173+ [ (name, expr) ]

174+

175+ P.Literal _ ->

176+ []

177+

178+ P.Record fields ->

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

180+

181+ P.Anything ->

182+ []

183+

184+ P.Alias alias realPattern ->

185+ (alias, expr) : substitutions expr realPattern

186+

187+ P.Data _ patterns ->

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

84189

85190

86191-- CONVERT EXPRESSIONS

87192

88−type Context = Maybe (String, Int)

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

89194

90195

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

196+findTailCalls :: Context -> Can.Expr -> Optimizer Opt.Expr

92197findTailCalls context annExpr@(A.A _ expression) =

93198 let

94199 keepLooking =

@@ -101,135 +206,185 @@ findTailCalls context annExpr@(A.A _ expression) =

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

102207 -- expressions that cannot be turned into tail calls

103208 in

104− A.A () <$>

105209 case expression of

106− Literal lit ->

107− pure (Literal lit)

210+ Expr.Literal lit ->

211+ pure (Opt.Literal lit)

108212

109− Var name ->

110− pure (Var name)

213+ Expr.Var name ->

214+ pure (Opt.Var name)

111215

112− Range lowExpr highExpr ->

113− Range

216+ Expr.Range lowExpr highExpr ->

217+ Opt.Range

114218 <$> justConvert lowExpr

115219 <*> justConvert highExpr

116220

117− ExplicitList elements ->

118− ExplicitList

221+ Expr.ExplicitList elements ->

222+ Opt.ExplicitList

119223 <$> T.traverse justConvert elements

120224

121− Binop op leftExpr rightExpr ->

122− Binop op

225+ Expr.Binop op leftExpr rightExpr ->

226+ Opt.Binop op

123227 <$> justConvert leftExpr

124228 <*> justConvert rightExpr

125229

126− Lambda pattern body ->

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

230+ Expr.Lambda _ _ ->

231+ let

232+ (patterns, body) =

233+ Expr.collectLambdas annExpr

234+ in

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

128236

129− App _ _ ->

237+ Expr.App _ _ ->

130238 let

131239 (func:args) =

132240 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

151241 in

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

242+ case isTailCall context func (length args) of

243+ Just (name, argNames) ->

244+ do optArgs <- T.traverse justConvert args

245+ setTailCall True

246+ return (Opt.TailCall name argNames optArgs)

247+

248+ Nothing ->

249+ do hasTailCall <- State.gets _hasTailCall

250+ optFunc <- justConvert func

251+ optArgs <- T.traverse justConvert args

252+ setTailCall hasTailCall

253+ return (Opt.Call optFunc optArgs)

153254

154255

155− If branches finally ->

256+ Expr.If branches finally ->

156257 let

157258 crawlBranch (cond,branch) =

158259 (,) <$> justConvert cond <*> keepLooking branch

159260 in

160− If

261+ Opt.If

161262 <$> T.traverse crawlBranch branches

162263 <*> keepLooking finally

163264

164− Let defs body ->

165− let

166− optDefs = map detectTailRecursion defs

167− in

168− Let optDefs <$> keepLooking body

265+ Expr.Let defs body ->

266+ do optDefs <- concat <$> T.traverse (definition Nothing) defs

267+ Opt.Let optDefs <$> keepLooking body

169268

170− Case expr cases ->

269+ Expr.Case expr rawBranches ->

171270 let

172− preppedCases =

173− map (first removeAnnotations) cases

271+ indexify index (pattern, branch) =

272+ ( (pattern, index)

273+ , (index, branch)

274+ )

275+

276+ (patterns, indexedBranches) =

277+ unzip (zipWith indexify [0..] rawBranches)

278+

279+ decisionTree =

280+ Cases.compile (error "need a VariantDict") patterns

281+

282+ branches =

283+ Map.fromList indexedBranches

174284 in

175− Case

285+ Opt.Case

176286 <$> justConvert expr

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

287+ <*> pure decisionTree

288+ <*> T.traverse keepLooking branches

178289

179− Data name exprs ->

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

290+ Expr.Data name exprs ->

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

181292

182− Access record field ->

183− Access

293+ Expr.Access record field ->

294+ Opt.Access

184295 <$> justConvert record

185296 <*> pure field

186297

187− Update record fields ->

188− Update

298+ Expr.Update record fields ->

299+ Opt.Update

189300 <$> justConvert record

190301 <*> T.traverse (mapSnd justConvert) fields

191302

192− Record fields ->

193− Record

303+ Expr.Record fields ->

304+ Opt.Record

194305 <$> T.traverse (mapSnd justConvert) fields

195306

196− GLShader uid src gltipe ->

197− pure (GLShader uid src gltipe)

307+ Expr.GLShader uid src gltipe ->

308+ pure (Opt.GLShader uid src gltipe)

198309

199− Port impl ->

200− Port <$>

310+ Expr.Port impl ->

311+ Opt.Port <$>

201312 case impl of

202− In name tipe ->

203− pure (In name tipe)

313+ Expr.In name tipe ->

314+ pure (Expr.In name tipe)

315+

316+ Expr.Out name expr tipe ->

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

318+

319+ Expr.Task name expr tipe ->

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

321+

322+

323+-- DETECT TAIL CALL

324+

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

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

327+ case (context, function) of

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

329+

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

331+ Just (name, argNames)

332+

333+ else

334+ Nothing

204335

205− Out name expr tipe ->

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

336+ _ ->

337+ Nothing

207338

208− Task name expr tipe ->

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

210339

211− Crash details ->

212− pure (Crash details)

213340

341+-- DEPATTERN

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

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

344+-- it out from there

345+

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

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

348+ let

349+ ann =

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

351+

352+ caseExpr e branches =

353+ ann (Expr.Case e branches)

354+

355+ var name =

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

357+

358+ caseify =

359+ do name <- freshName

360+ return

361+ ( name

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

363+ )

364+ in

365+ case pattern of

366+ P.Var name ->

367+ return (name, expr)

368+

369+ P.Literal _ ->

370+ caseify

214371

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

372+ P.Record _ ->

373+ caseify

221374

222− P.Literal lit ->

223− P.Literal lit

375+ P.Anything ->

376+ do name <- freshName

377+ return (name, expr)

224378

225− P.Record fields ->

226− P.Record fields

379+ P.Alias _ _ ->

380+ caseify

227381

228− P.Anything ->

229− P.Anything

382+ P.Data _ _ ->

383+ caseify

230384

231− P.Alias alias realPattern ->

232− P.Alias alias (removeAnnotations realPattern)

233385

234− P.Data name patterns ->

235− P.Data name (map removeAnnotations patterns)

386+freshName :: Optimizer String

387+freshName =

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

389+ State.put (Env htc (uid + 1))

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