git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Self-calls must not appear under a function in a tail call. Remove nested blocks during optimization.
3a9e363Phil Freeman
examples/passing/TailCall.purs+5
compare with golang
unifiedsplit
@@ -3,3 +3,8 @@ module TailCall where
3test n [] = n
3test n [] = n
4test n (x:xs) = test (n + x) xs
4test n (x:xs) = test (n + x) xs
5
5
6+loop x = loop (x + 1)
7+
8+notATailCall = \x ->
9+ (\notATailCall -> notATailCall x) (\x -> x)
10+
src/Language/PureScript/Optimize.hs+35−11
@@ -25,7 +25,13 @@ import Language.PureScript.CodeGen.JS.AST
25import Language.PureScript.Options
25import Language.PureScript.Options
26
26
27optimize :: Options -> JS -> JS
27optimize :: Options -> JS -> JS
28+optimize opts =
29+ collapseNestedBlocks
30+ . tco opts
28−optimize opts = removeUnusedVariables . unThunk . etaConvert . inlineVariables . tco opts
31+ . removeUnusedVariables
32+ . unThunk
33+ . etaConvert
34+ . inlineVariables
29
35
30replaceIdent :: (Data d) => Ident -> JS -> d -> d
36replaceIdent :: (Data d) => Ident -> JS -> d -> d
31replaceIdent var1 js = everywhere (mkT replace)
37replaceIdent var1 js = everywhere (mkT replace)
@@ -112,32 +118,39 @@ tco' = everywhere (mkT convert)
112 where
118 where
113 tcoLabel :: String
119 tcoLabel :: String
114 tcoLabel = "tco"
120 tcoLabel = "tco"
115− tcoRet :: Ident
116− tcoRet = Ident "__tco_ret"
117 tcoVar :: Ident -> Ident
121 tcoVar :: Ident -> Ident
118 tcoVar (Ident arg) = Ident $ "__tco_" ++ arg
122 tcoVar (Ident arg) = Ident $ "__tco_" ++ arg
119 tcoVar _ = error "Invalid name in tcoVar"
123 tcoVar _ = error "Invalid name in tcoVar"
120 convert :: JS -> JS
124 convert :: JS -> JS
121− convert (JSVariableIntroduction name (Just fn@(JSFunction Nothing _ body))) | isTailCall name body =
125+ convert js@(JSVariableIntroduction name (Just fn@(JSFunction Nothing _ _))) =
122 let
126 let
123 (argss, body', replace) = collectAllFunctionArgs [] id fn
127 (argss, body', replace) = collectAllFunctionArgs [] id fn
128+ in case () of
129+ _ | isTailCall name body' ->
130+ let
124− allArgs = reverse $ concat argss
131+ allArgs = reverse $ concat argss
125− in
132+ in
126− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
133+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
134+ | otherwise -> js
127 convert js = js
135 convert js = js
128 collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
136 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 _):_))) =
130 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing args (JSBlock [b]))) body
138 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing args (JSBlock [b]))) body
131 collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) =
139 collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) =
132 collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction Nothing args (JSBlock [b])))) body
140 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)))
133 collectAllFunctionArgs allArgs f body = (allArgs, body, f)
143 collectAllFunctionArgs allArgs f body = (allArgs, body, f)
134 isTailCall :: Ident -> JS -> Bool
144 isTailCall :: Ident -> JS -> Bool
135 isTailCall ident js =
145 isTailCall ident js =
136 let
146 let
137 numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
147 numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
138 numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
148 numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
149+ numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
139 in
150 in
151+ numSelfCalls > 0
140− numSelfCalls > 0 && numSelfCalls == numSelfCallsInTailPosition
152+ && numSelfCalls == numSelfCallsInTailPosition
153+ && numSelfCallsUnderFunctions == 0
141 where
154 where
142 countSelfCalls :: JS -> Int
155 countSelfCalls :: JS -> Int
143 countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
156 countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
@@ -145,10 +158,11 @@ tco' = everywhere (mkT convert)
145 countSelfCallsInTailPosition :: JS -> Int
158 countSelfCallsInTailPosition :: JS -> Int
146 countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
159 countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
147 countSelfCallsInTailPosition _ = 0
160 countSelfCallsInTailPosition _ = 0
161+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
162+ countSelfCallsUnderFunctions _ = 0
148 toLoop :: Ident -> [Ident] -> JS -> JS
163 toLoop :: Ident -> [Ident] -> JS -> JS
149 toLoop ident allArgs js = JSBlock
164 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 ]) ]
152 where
166 where
153 loopify :: JS -> JS
167 loopify :: JS -> JS
154 loopify (JSReturn ret) | isSelfCall ident ret =
168 loopify (JSReturn ret) | isSelfCall ident ret =
@@ -168,3 +182,13 @@ tco' = everywhere (mkT convert)
168 isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
182 isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
169 isSelfCall ident (JSApp fn _) = isSelfCall ident fn
183 isSelfCall ident (JSApp fn _) = isSelfCall ident fn
170 isSelfCall _ _ = False
184 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]