git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
First version of tail call optimization. Still need to figure out name shadowing and what happens when a return statement appears under a lambda.
commit50eb190dd5edb4108869502dd746475533995862 authorPhil Freeman <paf31@cantab.net> dateWed 8 Jan 2014, 17:49 (13 years ago) parent0ca3eaa
5 files changed+70−7
compare with golang
unifiedsplit
examples/passing/Arrays.purs−1 examples/passing/TailCall.purs+5 src/Language/PureScript/CodeGen/JS/AST.hs+4−1 src/Language/PureScript/Optimize.hs+55−5 src/Language/PureScript/Pretty/JS.hs+6
examples/passing/Arrays.purs−1
@@ -19,4 +19,3 @@ test4 = \arr -> case arr of
1919 [_] -> 0
2020 x : y : xs -> x * y + test4 xs
2121
22−
examples/passing/TailCall.pursnew file+5
@@ -0,0 +1,5 @@
1+module TailCall where
2+
3+test n [] = n
4+test n (x:xs) = test (n + x) xs
5+
src/Language/PureScript/CodeGen/JS/AST.hs+4−1
@@ -43,7 +43,10 @@ data JS
4343 | JSIfElse JS JS (Maybe JS)
4444 | JSReturn JS
4545 | JSThrow JS
46− | JSTypeOf JS deriving (Show, Data, Typeable)
46+ | JSTypeOf JS
47+ | JSLabel String JS
48+ | JSBreak String
49+ | JSContinue String deriving (Show, Data, Typeable)
4750
4851data JSAssignment
4952 = JSAssignVariable Ident
src/Language/PureScript/Optimize.hs+55−5
@@ -25,7 +25,7 @@ import Language.PureScript.CodeGen.JS.AST
2525import Language.PureScript.Options
2626
2727optimize :: Options -> JS -> JS
28−optimize opts = tco opts . removeUnusedVariables . unThunk . etaConvert . inlineVariables
28+optimize opts = removeUnusedVariables . unThunk . etaConvert . inlineVariables . tco opts
2929
3030replaceIdent :: (Data d) => Ident -> JS -> d -> d
3131replaceIdent var1 js = everywhere (mkT replace)
@@ -110,11 +110,61 @@ tco opts | optionsTco opts = tco'
110110tco' :: JS -> JS
111111tco' = everywhere (mkT convert)
112112 where
113+ tcoLabel :: String
114+ tcoLabel = "tco"
115+ tcoRet :: Ident
116+ tcoRet = Ident "__tco_ret"
117+ tcoVar :: Ident -> Ident
118+ tcoVar (Ident arg) = Ident $ "__tco_" ++ arg
119+ tcoVar _ = error "Invalid name in tcoVar"
113120 convert :: JS -> JS
114− convert (JSVariableIntroduction name (Just (JSFunction Nothing args body)))
115− | isTailCall name body = (JSVariableIntroduction name (Just (JSFunction Nothing args (toLoop name args body))))
121+ convert (JSVariableIntroduction name (Just fn@(JSFunction Nothing _ body))) | isTailCall name body =
122+ let
123+ (argss, body', replace) = collectAllFunctionArgs [] id fn
124+ allArgs = reverse $ concat argss
125+ in
126+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
116127 convert js = js
128+ collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
129+ collectAllFunctionArgs allArgs f (JSFunction Nothing args (JSBlock [body])) =
130+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing args (JSBlock [b]))) body
131+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) =
132+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction Nothing args (JSBlock [b])))) body
133+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
117134 isTailCall :: Ident -> JS -> Bool
118− isTailCall _ _ = False
135+ isTailCall ident js =
136+ let
137+ numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
138+ numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
139+ in
140+ numSelfCalls > 0 && numSelfCalls == numSelfCallsInTailPosition
141+ where
142+ countSelfCalls :: JS -> Int
143+ countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
144+ countSelfCalls _ = 0
145+ countSelfCallsInTailPosition :: JS -> Int
146+ countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
147+ countSelfCallsInTailPosition _ = 0
119148 toLoop :: Ident -> [Ident] -> JS -> JS
120− toLoop = undefined
149+ toLoop ident allArgs js = JSBlock
150+ [ JSVariableIntroduction tcoRet Nothing
151+ , JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
152+ where
153+ loopify :: JS -> JS
154+ loopify (JSReturn ret) | isSelfCall ident ret =
155+ let
156+ allArgumentValues = concat $ collectSelfCallArgs [] ret
157+ in
158+ JSBlock $ zipWith (\val arg ->
159+ JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
160+ ++ map (\arg ->
161+ JSAssignment (JSAssignVariable arg) (JSVar (tcoVar arg))) allArgs
162+ ++ [ JSContinue tcoLabel ]
163+ loopify other = other
164+ collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
165+ collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
166+ collectSelfCallArgs allArgumentValues _ = allArgumentValues
167+ isSelfCall :: Ident -> JS -> Bool
168+ isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
169+ isSelfCall ident (JSApp fn _) = isSelfCall ident fn
170+ isSelfCall _ _ = False
src/Language/PureScript/Pretty/JS.hs+6
@@ -118,6 +118,12 @@ literals = mkPattern' match
118118 [ return "throw "
119119 , prettyPrintJS' value
120120 ]
121+ match (JSBreak lbl) = return $ "break " ++ lbl
122+ match (JSContinue lbl) = return $ "continue " ++ lbl
123+ match (JSLabel lbl js) = fmap concat $ sequence
124+ [ return $ lbl ++ ": "
125+ , prettyPrintJS' js
126+ ]
121127 match _ = mzero
122128
123129targetToJs :: JSAssignment -> String