@@ -28,6 +28,8 @@ import qualified Reporting.Annotation as A
2828import qualified Reporting.Crash as Crash
2929
3030
31+-- HELPERS
32+
3133internalImports :: Module.Name -> [VarDecl ()]
3234internalImports name =
3335 [ varDecl "_N" (obj ["Elm","Native"])
@@ -114,15 +116,35 @@ toExpr code =
114116 function [] stmts `call` []
115117
116118
119+-- TAIL CALL CONTEXT
120+
121+type TailCallContext =
122+ Maybe (String, [String], Label)
123+
124+
125+type Label =
126+ Id ()
127+
128+
117129-- EXPRESSIONS
118130
119−exprToJsExpr :: Opt.Expr -> State Int (Expression ())
120−exprToJsExpr canonicalExpr =
121− toExpr <$> exprToCode canonicalExpr
131+toJsExpr :: Opt.Expr -> State Int (Expression ())
132+toJsExpr =
133+ exprToJsExpr Nothing
134+
135+
136+toCode :: Opt.Expr -> State Int Code
137+toCode =
138+ exprToCode Nothing
122139
123140
124−exprToCode :: Opt.Expr -> State Int Code
125−exprToCode annotatedExpr@(A.A _ expr) =
141+exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())
142+exprToJsExpr tcc canonicalExpr =
143+ toExpr <$> exprToCode tcc canonicalExpr
144+
145+
146+exprToCode :: TailCallContext -> Opt.Expr -> State Int Code
147+exprToCode tcc annotatedExpr@(A.A _ expr) =
126148 case expr of
127149 Var var ->
128150 jsExpr $ Var.canonical var
@@ -131,28 +153,28 @@ exprToCode annotatedExpr@(A.A _ expr) =
131153 jsExpr $ literal lit
132154
133155 Range lo hi ->
134− do lo' <- exprToJsExpr lo
135− hi' <- exprToJsExpr hi
156+ do lo' <- toJsExpr lo
157+ hi' <- toJsExpr hi
136158 jsExpr $ _List "range" `call` [lo',hi']
137159
138160 Access record field ->
139− do record' <- exprToJsExpr record
161+ do record' <- toJsExpr record
140162 jsExpr $ DotRef () record' (var (Var.varName field))
141163
142164 Remove record field ->
143− do record' <- exprToJsExpr record
165+ do record' <- toJsExpr record
144166 jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]
145167
146168 Insert record field value ->
147− do value' <- exprToJsExpr value
148− record' <- exprToJsExpr record
169+ do value' <- toJsExpr value
170+ record' <- toJsExpr record
149171 jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]
150172
151173 Modify record fields ->
152− do record' <- exprToJsExpr record
174+ do record' <- toJsExpr record
153175 fields' <-
154176 forM fields $ \(field, value) ->
155− do value' <- exprToJsExpr value
177+ do value' <- toJsExpr value
156178 return $ ArrayLit () [ string (Var.varName field), value' ]
157179
158180 jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
@@ -160,7 +182,7 @@ exprToCode annotatedExpr@(A.A _ expr) =
160182 Record fields ->
161183 do fields' <-
162184 forM fields $ \(field, e) ->
163− (,) (Var.varName field) <$> exprToJsExpr e
185+ (,) (Var.varName field) <$> toJsExpr e
164186
165187 let fieldMap =
166188 List.foldl' combine Map.empty fields'
@@ -183,37 +205,24 @@ exprToCode annotatedExpr@(A.A _ expr) =
183205 Lambda _ _ ->
184206 generateFunction (Expr.collectLambdas annotatedExpr)
185207
186− App funcExpr argExpr ->
187− do func' <- exprToJsExpr func
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)
208+ App _ _ ->
209+ generateApplication tcc annotatedExpr
201210
202211 Let defs body ->
203− generateLet defs body
212+ generateLet tcc defs body
204213
205214 MultiIf branches finally ->
206− generateIf branches finally
215+ generateIf tcc branches finally
207216
208217 Case expr branches ->
209− generateCase expr branches
218+ generateCase tcc expr branches
210219
211220 ExplicitList elements ->
212− do jsElements <- mapM exprToJsExpr elements
221+ do jsElements <- mapM toJsExpr elements
213222 jsExpr $ _List "fromArray" <| ArrayLit () jsElements
214223
215224 Data tag members ->
216− do jsMembers <- mapM exprToJsExpr members
225+ do jsMembers <- mapM toJsExpr members
217226 jsExpr $ ObjectLit () (ctor : fields jsMembers)
218227 where
219228 ctor = (prop "ctor", string tag)
@@ -229,11 +238,11 @@ exprToCode annotatedExpr@(A.A _ expr) =
229238 jsExpr (Port.inbound name portType)
230239
231240 Out name expr portType ->
232− do expr' <- exprToJsExpr expr
241+ do expr' <- toJsExpr expr
233242 jsExpr (Port.outbound name expr' portType)
234243
235244 Task name expr portType ->
236− do expr' <- exprToJsExpr expr
245+ do expr' <- toJsExpr expr
237246 jsExpr (Port.task name expr' portType)
238247
239248 Crash details ->
@@ -245,10 +254,20 @@ exprToCode annotatedExpr@(A.A _ expr) =
245254generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
246255generateFunction (args, initialBody) =
247256 do (argVars, patternDefs) <- destructuredArgs args
248− code <- generateLet patternDefs initialBody
257+ code <- generateLet Nothing patternDefs initialBody
249258 jsExpr (generateFunctionWithArity argVars code)
250259
251260
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+
252271generateFunctionWithArity :: [String] -> Code -> Expression ()
253272generateFunctionWithArity args code =
254273 let
@@ -287,34 +306,79 @@ destructPattern pattern@(A.A ann pat) =
287306 )
288307
289308
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+
290358-- LET EXPRESSIONS
291359
292360generateLet
293− :: [Opt.Def]
361+ :: TailCallContext
362+ -> [Opt.Def]
294363 -> Opt.Expr
295364 -> State Int Code
296−generateLet givenDefs givenBody =
365+generateLet tcc givenDefs givenBody =
297366 do let (defs, body) = flattenLets givenDefs givenBody
298− case defs of
299− [] ->
300− exprToCode body
301−
302− _ ->
303− do stmts <- concat <$> mapM defToStatements defs
304− code <- exprToCode body
305− jsBlock (stmts ++ toStatementList code)
367+ stmts <- concat <$> mapM defToStatements defs
368+ code <- exprToCode tcc body
369+ jsBlock (stmts ++ toStatementList code)
306370
307371
308372-- GENERATE IFS
309373
310−generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
311−generateIf givenBranches givenFinally =
374+generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
375+generateIf tcc givenBranches givenFinally =
312376 let
313377 (branches, finally) =
314378 crushIfs givenBranches givenFinally
315379
316380 convertBranch (condition, expr) =
317− (,) <$> exprToJsExpr condition <*> exprToCode expr
381+ (,) <$> toJsExpr condition <*> exprToCode tcc expr
318382
319383 ifExpression (condition, branch) otherwise =
320384 CondExpr () condition branch otherwise
@@ -323,7 +387,7 @@ generateIf givenBranches givenFinally =
323387 IfStmt () condition branch otherwise
324388 in
325389 do jsBranches <- mapM convertBranch branches
326− jsFinally <- exprToCode finally
390+ jsFinally <- exprToCode tcc finally
327391
328392 if any isBlock (jsFinally : map snd jsBranches)
329393 then
@@ -369,13 +433,14 @@ crushIfsHelp visitedBranches unvisitedBranches finally =
369433-- DEFINITIONS
370434
371435defToStatements :: Opt.Def -> State Int [Statement ()]
372−defToStatements (Opt.Definition facts pattern expr) =
436+defToStatements def@(Opt.Definition facts pattern expr) =
373437 case Opt.tailRecursionDetails facts of
374− Just (name, arity) ->
375− error "TODO" name arity
438+ Just name ->
439+ do func <- generateTailFunction name (Expr.collectLambdas expr)
440+ return [ VarDeclStmt () [ varDecl name func ] ]
376441
377442 Nothing ->
378− defToStatementsHelp facts pattern =<< exprToJsExpr expr
443+ defToStatementsHelp facts pattern =<< toJsExpr expr
379444
380445
381446defToStatementsHelp
@@ -442,8 +507,8 @@ defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
442507
443508-- CASE EXPRESSIONS
444509
445−generateCase :: Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
446−generateCase expr branches =
510+generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
511+generateCase tcc expr branches =
447512 do (tempVar, initialMatch) <-
448513 Case.toMatch branches
449514
@@ -452,20 +517,20 @@ generateCase expr branches =
452517 A.A _ (Var (Var.Canonical Var.Local x)) ->
453518 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
454519 _ ->
455− do expr' <- exprToJsExpr expr
520+ do expr' <- toJsExpr expr
456521 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
457522
458− match' <- match revisedMatch
523+ match' <- match tcc revisedMatch
459524
460525 jsBlock (stmt ++ match')
461526
462527
463−match :: Case.Match -> State Int [Statement ()]
464−match mtch =
528+match :: TailCallContext -> Case.Match -> State Int [Statement ()]
529+match tcc mtch =
465530 case mtch of
466531 Case.Match name clauses mtch' ->
467− do (isChars, clauses') <- unzip <$> mapM (clause name) clauses
468− mtch'' <- match mtch'
532+ do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
533+ mtch'' <- match tcc mtch'
469534 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
470535 where
471536 isLiteral p =
@@ -494,10 +559,10 @@ match mtch =
494559 return [BreakStmt () Nothing]
495560
496561 Case.Other expr ->
497− toStatementList <$> exprToCode expr
562+ toStatementList <$> exprToCode tcc expr
498563
499564 Case.Seq ms ->
500− concat <$> mapM match (dropEnd [] ms)
565+ concat <$> mapM (match tcc) (dropEnd [] ms)
501566 where
502567 dropEnd acc [] = acc
503568 dropEnd acc (m:ms) =
@@ -506,9 +571,10 @@ match mtch =
506571 _ -> dropEnd (acc ++ [m]) ms
507572
508573
509−clause :: String -> Case.Clause -> State Int (Bool, CaseClause ())
510−clause variable (Case.Clause value vars mtch) =
511− (,) isChar . CaseClause () pattern <$> match (Case.matchSubst (zip vars vars') mtch)
574+clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
575+clause tcc variable (Case.Clause value vars mtch) =
576+ do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
577+ return ((,) isChar (CaseClause () pattern statemens))
512578 where
513579 vars' =
514580 map (\n -> variable ++ "._" ++ show n) [0..]
@@ -627,7 +693,7 @@ binop
627693 -> State Int Code
628694binop func left right
629695 | func == Var.Canonical Var.BuiltIn "::" =
630− exprToCode (A.A () (Data "::" [left,right]))
696+ toCode (A.A () (Data "::" [left,right]))
631697
632698 | func == forwardCompose =
633699 compose (collectLeftAssoc forwardCompose left right)
@@ -642,8 +708,8 @@ binop func left right
642708 pipe (collectRightAssoc backwardApply left right)
643709
644710 | otherwise =
645− do jsLeft <- exprToJsExpr left
646− jsRight <- exprToJsExpr right
711+ do jsLeft <- toJsExpr left
712+ jsRight <- toJsExpr right
647713 jsExpr (makeExpr func jsLeft jsRight)
648714
649715
@@ -656,13 +722,13 @@ apply arg func =
656722
657723compose :: [Opt.Expr] -> State Int Code
658724compose functions =
659− do jsFunctions <- mapM exprToJsExpr functions
725+ do jsFunctions <- mapM toJsExpr functions
660726 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
661727
662728
663729pipe :: [Opt.Expr] -> State Int Code
664730pipe expressions =
665− do (value:functions) <- mapM exprToJsExpr expressions
731+ do (value:functions) <- mapM toJsExpr expressions
666732 jsExpr $ List.foldl' apply value functions
667733
668734