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.
05e2a65Phil Freeman
examples/passing/Arrays.purs−1
compare with golang
unifiedsplit
@@ -19,4 +19,3 @@ test4 = \arr -> case arr of
19 [_] -> 0
19 [_] -> 0
20 x : y : xs -> x * y + test4 xs
20 x : y : xs -> x * y + test4 xs
21
21
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
43 | JSIfElse JS JS (Maybe JS)
43 | JSIfElse JS JS (Maybe JS)
44 | JSReturn JS
44 | JSReturn JS
45 | JSThrow JS
45 | JSThrow JS
46+ | JSTypeOf JS
47+ | JSLabel String JS
48+ | JSBreak String
46− | JSTypeOf JS deriving (Show, Data, Typeable)
49+ | JSContinue String deriving (Show, Data, Typeable)
47
50
48data JSAssignment
51data JSAssignment
49 = JSAssignVariable Ident
52 = JSAssignVariable Ident
src/Language/PureScript/Optimize.hs+55−5
@@ -25,7 +25,7 @@ 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 = tco opts . removeUnusedVariables . unThunk . etaConvert . inlineVariables
28+optimize opts = removeUnusedVariables . unThunk . etaConvert . inlineVariables . tco opts
29
29
30replaceIdent :: (Data d) => Ident -> JS -> d -> d
30replaceIdent :: (Data d) => Ident -> JS -> d -> d
31replaceIdent var1 js = everywhere (mkT replace)
31replaceIdent var1 js = everywhere (mkT replace)
@@ -110,11 +110,61 @@ tco opts | optionsTco opts = tco'
110tco' :: JS -> JS
110tco' :: JS -> JS
111tco' = everywhere (mkT convert)
111tco' = everywhere (mkT convert)
112 where
112 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"
113 convert :: JS -> JS
120 convert :: JS -> JS
114− convert (JSVariableIntroduction name (Just (JSFunction Nothing 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
115− | isTailCall name body = (JSVariableIntroduction name (Just (JSFunction Nothing args (toLoop name args body))))
126+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
116 convert js = js
127 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)
117 isTailCall :: Ident -> JS -> Bool
134 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
119 toLoop :: Ident -> [Ident] -> JS -> JS
148 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
118 [ return "throw "
118 [ return "throw "
119 , prettyPrintJS' value
119 , prettyPrintJS' value
120 ]
120 ]
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+ ]
121 match _ = mzero
127 match _ = mzero
122
128
123targetToJs :: JSAssignment -> String
129targetToJs :: JSAssignment -> String