@@ -25,7 +25,13 @@ import Language.PureScript.CodeGen.JS.AST
2525import Language.PureScript.Options
2626
2727optimize :: Options -> JS -> JS
28−optimize opts = removeUnusedVariables . unThunk . etaConvert . inlineVariables . tco opts
28+optimize opts =
29+ collapseNestedBlocks
30+ . tco opts
31+ . removeUnusedVariables
32+ . unThunk
33+ . etaConvert
34+ . inlineVariables
2935
3036replaceIdent :: (Data d) => Ident -> JS -> d -> d
3137replaceIdent var1 js = everywhere (mkT replace)
@@ -112,32 +118,39 @@ tco' = everywhere (mkT convert)
112118 where
113119 tcoLabel :: String
114120 tcoLabel = "tco"
115− tcoRet :: Ident
116− tcoRet = Ident "__tco_ret"
117121 tcoVar :: Ident -> Ident
118122 tcoVar (Ident arg) = Ident $ "__tco_" ++ arg
119123 tcoVar _ = error "Invalid name in tcoVar"
120124 convert :: JS -> JS
121− convert (JSVariableIntroduction name (Just fn@(JSFunction Nothing _ body))) | isTailCall name body =
125+ convert js@(JSVariableIntroduction name (Just fn@(JSFunction Nothing _ _))) =
122126 let
123127 (argss, body', replace) = collectAllFunctionArgs [] id fn
124− allArgs = reverse $ concat argss
125− in
126− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
128+ in case () of
129+ _ | isTailCall name body' ->
130+ let
131+ allArgs = reverse $ concat argss
132+ in
133+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
134+ | otherwise -> js
127135 convert js = js
128136 collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
129− collectAllFunctionArgs allArgs f (JSFunction Nothing args (JSBlock [body])) =
137+ collectAllFunctionArgs allArgs f (JSFunction Nothing args (JSBlock (body@(JSReturn _):_))) =
130138 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing args (JSBlock [b]))) body
131139 collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) =
132140 collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction Nothing args (JSBlock [b])))) body
141+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args body@(JSBlock _))) =
142+ (args : allArgs, body, \b -> f (JSReturn (JSFunction Nothing args b)))
133143 collectAllFunctionArgs allArgs f body = (allArgs, body, f)
134144 isTailCall :: Ident -> JS -> Bool
135145 isTailCall ident js =
136146 let
137147 numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
138148 numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
149+ numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
139150 in
140− numSelfCalls > 0 && numSelfCalls == numSelfCallsInTailPosition
151+ numSelfCalls > 0
152+ && numSelfCalls == numSelfCallsInTailPosition
153+ && numSelfCallsUnderFunctions == 0
141154 where
142155 countSelfCalls :: JS -> Int
143156 countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
@@ -145,10 +158,11 @@ tco' = everywhere (mkT convert)
145158 countSelfCallsInTailPosition :: JS -> Int
146159 countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
147160 countSelfCallsInTailPosition _ = 0
161+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
162+ countSelfCallsUnderFunctions _ = 0
148163 toLoop :: Ident -> [Ident] -> JS -> JS
149164 toLoop ident allArgs js = JSBlock
150− [ JSVariableIntroduction tcoRet Nothing
151− , JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
165+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
152166 where
153167 loopify :: JS -> JS
154168 loopify (JSReturn ret) | isSelfCall ident ret =
@@ -168,3 +182,13 @@ tco' = everywhere (mkT convert)
168182 isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
169183 isSelfCall ident (JSApp fn _) = isSelfCall ident fn
170184 isSelfCall _ _ = False
185+
186+collapseNestedBlocks :: JS -> JS
187+collapseNestedBlocks = everywhere (mkT collapse)
188+ where
189+ collapse :: JS -> JS
190+ collapse (JSBlock sts) = JSBlock (concatMap go sts)
191+ collapse js = js
192+ go :: JS -> [JS]
193+ go (JSBlock sts) = sts
194+ go s = [s]