git.iko.soy/elk
on master help sign in
Finish tail call elimination
5c78998Evan Czaplicki
src/AST/Expression/Optimized.hs+1−1
compare with master
unifiedsplit
@@ -25,7 +25,7 @@ data Def
25
25
26
26
27data Facts = Facts
27data Facts = Facts
28− { tailRecursionDetails :: Maybe (String, Int)
28+ { tailRecursionDetails :: Maybe String
29 }
29 }
30 deriving (Show)
30 deriving (Show)
31
31
src/Generate/JavaScript.hs+139−73
@@ -28,6 +28,8 @@ import qualified Reporting.Annotation as A
28import qualified Reporting.Crash as Crash
28import qualified Reporting.Crash as Crash
29
29
30
30
31+-- HELPERS
32+
31internalImports :: Module.Name -> [VarDecl ()]
33internalImports :: Module.Name -> [VarDecl ()]
32internalImports name =
34internalImports name =
33 [ varDecl "_N" (obj ["Elm","Native"])
35 [ varDecl "_N" (obj ["Elm","Native"])
@@ -114,15 +116,35 @@ toExpr code =
114 function [] stmts `call` []
116 function [] stmts `call` []
115
117
116
118
119+-- TAIL CALL CONTEXT
120+
121+type TailCallContext =
122+ Maybe (String, [String], Label)
123+
124+
125+type Label =
126+ Id ()
127+
128+
117-- EXPRESSIONS
129-- EXPRESSIONS
118
130
119−exprToJsExpr :: Opt.Expr -> State Int (Expression ())
131+toJsExpr :: Opt.Expr -> State Int (Expression ())
120−exprToJsExpr canonicalExpr =
132+toJsExpr =
133+ exprToJsExpr Nothing
134+
135+
136+toCode :: Opt.Expr -> State Int Code
137+toCode =
121− toExpr <$> exprToCode canonicalExpr
138+ exprToCode Nothing
122
139
123
140
141+exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())
142+exprToJsExpr tcc canonicalExpr =
143+ toExpr <$> exprToCode tcc canonicalExpr
144+
145+
124−exprToCode :: Opt.Expr -> State Int Code
146+exprToCode :: TailCallContext -> Opt.Expr -> State Int Code
125−exprToCode annotatedExpr@(A.A _ expr) =
147+exprToCode tcc annotatedExpr@(A.A _ expr) =
126 case expr of
148 case expr of
127 Var var ->
149 Var var ->
128 jsExpr $ Var.canonical var
150 jsExpr $ Var.canonical var
@@ -131,28 +153,28 @@ exprToCode annotatedExpr@(A.A _ expr) =
131 jsExpr $ literal lit
153 jsExpr $ literal lit
132
154
133 Range lo hi ->
155 Range lo hi ->
134− do lo' <- exprToJsExpr lo
156+ do lo' <- toJsExpr lo
135− hi' <- exprToJsExpr hi
157+ hi' <- toJsExpr hi
136 jsExpr $ _List "range" `call` [lo',hi']
158 jsExpr $ _List "range" `call` [lo',hi']
137
159
138 Access record field ->
160 Access record field ->
139− do record' <- exprToJsExpr record
161+ do record' <- toJsExpr record
140 jsExpr $ DotRef () record' (var (Var.varName field))
162 jsExpr $ DotRef () record' (var (Var.varName field))
141
163
142 Remove record field ->
164 Remove record field ->
143− do record' <- exprToJsExpr record
165+ do record' <- toJsExpr record
144 jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]
166 jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]
145
167
146 Insert record field value ->
168 Insert record field value ->
147− do value' <- exprToJsExpr value
169+ do value' <- toJsExpr value
148− record' <- exprToJsExpr record
170+ record' <- toJsExpr record
149 jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]
171 jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]
150
172
151 Modify record fields ->
173 Modify record fields ->
152− do record' <- exprToJsExpr record
174+ do record' <- toJsExpr record
153 fields' <-
175 fields' <-
154 forM fields $ \(field, value) ->
176 forM fields $ \(field, value) ->
155− do value' <- exprToJsExpr value
177+ do value' <- toJsExpr value
156 return $ ArrayLit () [ string (Var.varName field), value' ]
178 return $ ArrayLit () [ string (Var.varName field), value' ]
157
179
158 jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
180 jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
@@ -160,7 +182,7 @@ exprToCode annotatedExpr@(A.A _ expr) =
160 Record fields ->
182 Record fields ->
161 do fields' <-
183 do fields' <-
162 forM fields $ \(field, e) ->
184 forM fields $ \(field, e) ->
163− (,) (Var.varName field) <$> exprToJsExpr e
185+ (,) (Var.varName field) <$> toJsExpr e
164
186
165 let fieldMap =
187 let fieldMap =
166 List.foldl' combine Map.empty fields'
188 List.foldl' combine Map.empty fields'
@@ -183,37 +205,24 @@ exprToCode annotatedExpr@(A.A _ expr) =
183 Lambda _ _ ->
205 Lambda _ _ ->
184 generateFunction (Expr.collectLambdas annotatedExpr)
206 generateFunction (Expr.collectLambdas annotatedExpr)
185
207
186− App funcExpr argExpr ->
208+ App _ _ ->
187− do func' <- exprToJsExpr func
209+ generateApplication tcc annotatedExpr
188− args' <- mapM exprToJsExpr args
189− jsExpr $
190− case args' of
191− [arg] -> func' <| arg
192− _ | length args' <= 9 -> ref aN `call` (func':args')
193− | otherwise -> foldl1 (<|) (func':args')
194− where
195− aN = "A" ++ show (length args)
196− (func, args) = getArgs funcExpr [argExpr]
197− getArgs func args =
198− case func of
199− (A.A _ (App f arg)) -> getArgs f (arg : args)
200− _ -> (func, args)
201
210
202 Let defs body ->
211 Let defs body ->
203− generateLet defs body
212+ generateLet tcc defs body
204
213
205 MultiIf branches finally ->
214 MultiIf branches finally ->
206− generateIf branches finally
215+ generateIf tcc branches finally
207
216
208 Case expr branches ->
217 Case expr branches ->
209− generateCase expr branches
218+ generateCase tcc expr branches
210
219
211 ExplicitList elements ->
220 ExplicitList elements ->
212− do jsElements <- mapM exprToJsExpr elements
221+ do jsElements <- mapM toJsExpr elements
213 jsExpr $ _List "fromArray" <| ArrayLit () jsElements
222 jsExpr $ _List "fromArray" <| ArrayLit () jsElements
214
223
215 Data tag members ->
224 Data tag members ->
216− do jsMembers <- mapM exprToJsExpr members
225+ do jsMembers <- mapM toJsExpr members
217 jsExpr $ ObjectLit () (ctor : fields jsMembers)
226 jsExpr $ ObjectLit () (ctor : fields jsMembers)
218 where
227 where
219 ctor = (prop "ctor", string tag)
228 ctor = (prop "ctor", string tag)
@@ -229,11 +238,11 @@ exprToCode annotatedExpr@(A.A _ expr) =
229 jsExpr (Port.inbound name portType)
238 jsExpr (Port.inbound name portType)
230
239
231 Out name expr portType ->
240 Out name expr portType ->
232− do expr' <- exprToJsExpr expr
241+ do expr' <- toJsExpr expr
233 jsExpr (Port.outbound name expr' portType)
242 jsExpr (Port.outbound name expr' portType)
234
243
235 Task name expr portType ->
244 Task name expr portType ->
236− do expr' <- exprToJsExpr expr
245+ do expr' <- toJsExpr expr
237 jsExpr (Port.task name expr' portType)
246 jsExpr (Port.task name expr' portType)
238
247
239 Crash details ->
248 Crash details ->
@@ -245,10 +254,20 @@ exprToCode annotatedExpr@(A.A _ expr) =
245generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
254generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
246generateFunction (args, initialBody) =
255generateFunction (args, initialBody) =
247 do (argVars, patternDefs) <- destructuredArgs args
256 do (argVars, patternDefs) <- destructuredArgs args
248− code <- generateLet patternDefs initialBody
257+ code <- generateLet Nothing patternDefs initialBody
249 jsExpr (generateFunctionWithArity argVars code)
258 jsExpr (generateFunctionWithArity argVars code)
250
259
251
260
261+generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())
262+generateTailFunction name (args, initialBody) =
263+ do (argVars, patternDefs) <- destructuredArgs args
264+ label <- Id () <$> Case.newVar
265+ code <- generateLet (Just (name, argVars, label)) patternDefs initialBody
266+ let whileLoop =
267+ JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]
268+ return (generateFunctionWithArity argVars whileLoop)
269+
270+
252generateFunctionWithArity :: [String] -> Code -> Expression ()
271generateFunctionWithArity :: [String] -> Code -> Expression ()
253generateFunctionWithArity args code =
272generateFunctionWithArity args code =
254 let
273 let
@@ -287,34 +306,79 @@ destructPattern pattern@(A.A ann pat) =
287 )
306 )
288
307
289
308
309+-- APPLICATIONS
310+
311+generateApplication :: TailCallContext -> Opt.Expr -> State Int Code
312+generateApplication tcc expr =
313+ let
314+ (func:args) =
315+ Expr.collectApps expr
316+
317+ arity =
318+ length args
319+
320+ reassign name tempName =
321+ ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
322+
323+ aN =
324+ "A" ++ show arity
325+ in
326+ case isTailCall tcc func arity of
327+ Just (argNames, label) ->
328+ do args' <- mapM toJsExpr args
329+ tempNames <- mapM (\_ -> Case.newVar) args
330+ jsBlock $
331+ VarDeclStmt () (zipWith varDecl tempNames args')
332+ : zipWith reassign argNames tempNames
333+ ++ [ContinueStmt () (Just label)]
334+
335+ _ ->
336+ do func' <- toJsExpr func
337+ args' <- mapM toJsExpr args
338+ jsExpr $
339+ if 2 <= arity && arity <= 9 then
340+ ref aN `call` (func':args')
341+ else
342+ foldl1 (<|) (func':args')
343+
344+
345+isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)
346+isTailCall tcc (A.A _ func) arity =
347+ case (func, tcc) of
348+ (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->
349+ if name == tcName && length tcArgs == arity then
350+ Just (tcArgs, tcLabel)
351+ else
352+ Nothing
353+
354+ _ ->
355+ Nothing
356+
357+
290-- LET EXPRESSIONS
358-- LET EXPRESSIONS
291
359
292generateLet
360generateLet
361+ :: TailCallContext
293− :: [Opt.Def]
362+ -> [Opt.Def]
294 -> Opt.Expr
363 -> Opt.Expr
295 -> State Int Code
364 -> State Int Code
296−generateLet givenDefs givenBody =
365+generateLet tcc givenDefs givenBody =
297 do let (defs, body) = flattenLets givenDefs givenBody
366 do let (defs, body) = flattenLets givenDefs givenBody
298− case defs of
299− [] ->
300− exprToCode body
301−
302− _ ->
303− do stmts <- concat <$> mapM defToStatements defs
367+ stmts <- concat <$> mapM defToStatements defs
304− code <- exprToCode body
368+ code <- exprToCode tcc body
305− jsBlock (stmts ++ toStatementList code)
369+ jsBlock (stmts ++ toStatementList code)
306
370
307
371
308-- GENERATE IFS
372-- GENERATE IFS
309
373
310−generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
374+generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
311−generateIf givenBranches givenFinally =
375+generateIf tcc givenBranches givenFinally =
312 let
376 let
313 (branches, finally) =
377 (branches, finally) =
314 crushIfs givenBranches givenFinally
378 crushIfs givenBranches givenFinally
315
379
316 convertBranch (condition, expr) =
380 convertBranch (condition, expr) =
317− (,) <$> exprToJsExpr condition <*> exprToCode expr
381+ (,) <$> toJsExpr condition <*> exprToCode tcc expr
318
382
319 ifExpression (condition, branch) otherwise =
383 ifExpression (condition, branch) otherwise =
320 CondExpr () condition branch otherwise
384 CondExpr () condition branch otherwise
@@ -323,7 +387,7 @@ generateIf givenBranches givenFinally =
323 IfStmt () condition branch otherwise
387 IfStmt () condition branch otherwise
324 in
388 in
325 do jsBranches <- mapM convertBranch branches
389 do jsBranches <- mapM convertBranch branches
326− jsFinally <- exprToCode finally
390+ jsFinally <- exprToCode tcc finally
327
391
328 if any isBlock (jsFinally : map snd jsBranches)
392 if any isBlock (jsFinally : map snd jsBranches)
329 then
393 then
@@ -369,13 +433,14 @@ crushIfsHelp visitedBranches unvisitedBranches finally =
369-- DEFINITIONS
433-- DEFINITIONS
370
434
371defToStatements :: Opt.Def -> State Int [Statement ()]
435defToStatements :: Opt.Def -> State Int [Statement ()]
372−defToStatements (Opt.Definition facts pattern expr) =
436+defToStatements def@(Opt.Definition facts pattern expr) =
373 case Opt.tailRecursionDetails facts of
437 case Opt.tailRecursionDetails facts of
374− Just (name, arity) ->
438+ Just name ->
375− error "TODO" name arity
439+ do func <- generateTailFunction name (Expr.collectLambdas expr)
440+ return [ VarDeclStmt () [ varDecl name func ] ]
376
441
377 Nothing ->
442 Nothing ->
378− defToStatementsHelp facts pattern =<< exprToJsExpr expr
443+ defToStatementsHelp facts pattern =<< toJsExpr expr
379
444
380
445
381defToStatementsHelp
446defToStatementsHelp
@@ -442,8 +507,8 @@ defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
442
507
443-- CASE EXPRESSIONS
508-- CASE EXPRESSIONS
444
509
445−generateCase :: Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
510+generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
446−generateCase expr branches =
511+generateCase tcc expr branches =
447 do (tempVar, initialMatch) <-
512 do (tempVar, initialMatch) <-
448 Case.toMatch branches
513 Case.toMatch branches
449
514
@@ -452,20 +517,20 @@ generateCase expr branches =
452 A.A _ (Var (Var.Canonical Var.Local x)) ->
517 A.A _ (Var (Var.Canonical Var.Local x)) ->
453 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
518 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
454 _ ->
519 _ ->
455− do expr' <- exprToJsExpr expr
520+ do expr' <- toJsExpr expr
456 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
521 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
457
522
458− match' <- match revisedMatch
523+ match' <- match tcc revisedMatch
459
524
460 jsBlock (stmt ++ match')
525 jsBlock (stmt ++ match')
461
526
462
527
463−match :: Case.Match -> State Int [Statement ()]
528+match :: TailCallContext -> Case.Match -> State Int [Statement ()]
464−match mtch =
529+match tcc mtch =
465 case mtch of
530 case mtch of
466 Case.Match name clauses mtch' ->
531 Case.Match name clauses mtch' ->
467− do (isChars, clauses') <- unzip <$> mapM (clause name) clauses
532+ do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
468− mtch'' <- match mtch'
533+ mtch'' <- match tcc mtch'
469 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
534 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
470 where
535 where
471 isLiteral p =
536 isLiteral p =
@@ -494,10 +559,10 @@ match mtch =
494 return [BreakStmt () Nothing]
559 return [BreakStmt () Nothing]
495
560
496 Case.Other expr ->
561 Case.Other expr ->
497− toStatementList <$> exprToCode expr
562+ toStatementList <$> exprToCode tcc expr
498
563
499 Case.Seq ms ->
564 Case.Seq ms ->
500− concat <$> mapM match (dropEnd [] ms)
565+ concat <$> mapM (match tcc) (dropEnd [] ms)
501 where
566 where
502 dropEnd acc [] = acc
567 dropEnd acc [] = acc
503 dropEnd acc (m:ms) =
568 dropEnd acc (m:ms) =
@@ -506,9 +571,10 @@ match mtch =
506 _ -> dropEnd (acc ++ [m]) ms
571 _ -> dropEnd (acc ++ [m]) ms
507
572
508
573
509−clause :: String -> Case.Clause -> State Int (Bool, CaseClause ())
574+clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
510−clause variable (Case.Clause value vars mtch) =
575+clause tcc variable (Case.Clause value vars mtch) =
511− (,) isChar . CaseClause () pattern <$> match (Case.matchSubst (zip vars vars') mtch)
576+ do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
577+ return ((,) isChar (CaseClause () pattern statemens))
512 where
578 where
513 vars' =
579 vars' =
514 map (\n -> variable ++ "._" ++ show n) [0..]
580 map (\n -> variable ++ "._" ++ show n) [0..]
@@ -627,7 +693,7 @@ binop
627 -> State Int Code
693 -> State Int Code
628binop func left right
694binop func left right
629 | func == Var.Canonical Var.BuiltIn "::" =
695 | func == Var.Canonical Var.BuiltIn "::" =
630− exprToCode (A.A () (Data "::" [left,right]))
696+ toCode (A.A () (Data "::" [left,right]))
631
697
632 | func == forwardCompose =
698 | func == forwardCompose =
633 compose (collectLeftAssoc forwardCompose left right)
699 compose (collectLeftAssoc forwardCompose left right)
@@ -642,8 +708,8 @@ binop func left right
642 pipe (collectRightAssoc backwardApply left right)
708 pipe (collectRightAssoc backwardApply left right)
643
709
644 | otherwise =
710 | otherwise =
645− do jsLeft <- exprToJsExpr left
711+ do jsLeft <- toJsExpr left
646− jsRight <- exprToJsExpr right
712+ jsRight <- toJsExpr right
647 jsExpr (makeExpr func jsLeft jsRight)
713 jsExpr (makeExpr func jsLeft jsRight)
648
714
649
715
@@ -656,13 +722,13 @@ apply arg func =
656
722
657compose :: [Opt.Expr] -> State Int Code
723compose :: [Opt.Expr] -> State Int Code
658compose functions =
724compose functions =
659− do jsFunctions <- mapM exprToJsExpr functions
725+ do jsFunctions <- mapM toJsExpr functions
660 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
726 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
661
727
662
728
663pipe :: [Opt.Expr] -> State Int Code
729pipe :: [Opt.Expr] -> State Int Code
664pipe expressions =
730pipe expressions =
665− do (value:functions) <- mapM exprToJsExpr expressions
731+ do (value:functions) <- mapM toJsExpr expressions
666 jsExpr $ List.foldl' apply value functions
732 jsExpr $ List.foldl' apply value functions
667
733
668
734
src/Optimize/TailCalls.hs+5−2
@@ -68,11 +68,14 @@ detectTailRecursion (Can.Definition pattern expression _) =
68
68
69 (Result isTailCall optExpr) =
69 (Result isTailCall optExpr) =
70 findTailCalls context body
70 findTailCalls context body
71+
72+ lambda x e =
73+ A.A () (Lambda x e)
71 in
74 in
72 Opt.Definition
75 Opt.Definition
73− (Opt.Facts (if isTailCall then context else Nothing))
76+ (Opt.Facts (if isTailCall then fmap fst context else Nothing))
74 (removeAnnotations pattern)
77 (removeAnnotations pattern)
75− optExpr
78+ (foldr lambda optExpr (map removeAnnotations args))
76
79
77
80
78-- CONVERT EXPRESSIONS
81-- CONVERT EXPRESSIONS