git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix some bugs with --magic-do, and make it work with TCO
b2763cePhil Freeman
libraries/prelude/tests/Eff.purs+8
compare with golang
unifiedsplit
@@ -21,3 +21,11 @@ test3 n = catchError (\s -> eff do return 0) $ eff do
21 trace "n > 10"
21 trace "n > 10"
22 throwError "Error!"
22 throwError "Error!"
23 _ -> eff do return n
23 _ -> eff do return n
24+
25+test4 = eff do
26+ trace "Hello World!"
27+ return 0
28+
29+test5 = eff do
30+ trace "Hello World!"
31+ test5
src/Language/PureScript/CodeGen/Optimize.hs+19−14
@@ -27,8 +27,8 @@ import Language.PureScript.Options
27optimize :: Options -> JS -> JS
27optimize :: Options -> JS -> JS
28optimize opts =
28optimize opts =
29 collapseNestedBlocks
29 collapseNestedBlocks
30− . magicDo opts
31 . tco opts
30 . tco opts
31+ . magicDo opts
32 . removeUnusedVariables
32 . removeUnusedVariables
33 . unThunk
33 . unThunk
34 . etaConvert
34 . etaConvert
@@ -134,7 +134,7 @@ tco' = everywhere (mkT convert)
134 copyVar (Ident arg) = Ident $ "__copy_" ++ arg
134 copyVar (Ident arg) = Ident $ "__copy_" ++ arg
135 copyVar _ = error "Invalid name in copyVar"
135 copyVar _ = error "Invalid name in copyVar"
136 convert :: JS -> JS
136 convert :: JS -> JS
137− convert js@(JSVariableIntroduction name (Just fn@(JSFunction Nothing _ _))) =
137+ convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =
138 let
138 let
139 (argss, body', replace) = collectAllFunctionArgs [] id fn
139 (argss, body', replace) = collectAllFunctionArgs [] id fn
140 in case () of
140 in case () of
@@ -146,12 +146,14 @@ tco' = everywhere (mkT convert)
146 | otherwise -> js
146 | otherwise -> js
147 convert js = js
147 convert js = js
148 collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
148 collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
149− collectAllFunctionArgs allArgs f (JSFunction Nothing args (JSBlock (body@(JSReturn _):_))) =
149+ collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
150− collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing (map copyVar args) (JSBlock [b]))) body
150+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
151+ collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
152+ (args : allArgs, body, \b -> f (JSFunction ident (map copyVar args) b))
151− collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) =
153+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
152− collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction Nothing (map copyVar args) (JSBlock [b])))) body
154+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
153− collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args body@(JSBlock _))) =
155+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
154− (args : allArgs, body, \b -> f (JSReturn (JSFunction Nothing (map copyVar args) b)))
156+ (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))
155 collectAllFunctionArgs allArgs f body = (allArgs, body, f)
157 collectAllFunctionArgs allArgs f body = (allArgs, body, f)
156 isTailCall :: Ident -> JS -> Bool
158 isTailCall :: Ident -> JS -> Bool
157 isTailCall ident js =
159 isTailCall ident js =
@@ -201,19 +203,22 @@ magicDo opts | optionsMagicDo opts = magicDo'
201 | otherwise = id
203 | otherwise = id
202
204
203magicDo' :: JS -> JS
205magicDo' :: JS -> JS
204−magicDo' = everywhere (mkT undo) . everywhere (mkT convert)
206+magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
205 where
207 where
206 fnName = Ident "__do"
208 fnName = Ident "__do"
207 convert :: JS -> JS
209 convert :: JS -> JS
210+ convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
208− convert (JSApp (JSApp (bind) [m]) [JSFunction Nothing [Ident "_"] (JSBlock [JSReturn ret])]) | isBind bind =
211+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [Ident "_"] (JSBlock [JSReturn ret])]) | isBind bind =
209− JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSApp ret [] ]
212+ JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
210− convert (JSApp (JSApp (bind) [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
213+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
211− JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSApp ret [] ]
214+ JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
212 convert other = other
215 convert other = other
213 isBind (JSAccessor "bind" (JSAccessor "eff" (JSVar (Ident "Eff")))) = True
216 isBind (JSAccessor "bind" (JSAccessor "eff" (JSVar (Ident "Eff")))) = True
214 isBind _ = False
217 isBind _ = False
218+ isReturn (JSAccessor "ret" (JSAccessor "eff" (JSVar (Ident "Eff")))) = True
219+ isReturn _ = False
215 undo :: JS -> JS
220 undo :: JS -> JS
216− undo (JSApp (JSFunction (Just ident) [] body) []) | ident == fnName = body
221+ undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
217 undo other = other
222 undo other = other
218
223
219collapseNestedBlocks :: JS -> JS
224collapseNestedBlocks :: JS -> JS