git.iko.soy/rowtype-yoga/purescript-native
on 05e2a65 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Optimize.hs
170 lines 6.2 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.Optimize
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15module Language.PureScript.Optimize (
16 optimize
17) where
19import Data.Data
20import Data.Maybe (fromMaybe)
21import Data.Generics
23import Language.PureScript.Names
24import Language.PureScript.CodeGen.JS.AST
25import Language.PureScript.Options
27optimize :: Options -> JS -> JS
28optimize opts = removeUnusedVariables . unThunk . etaConvert . inlineVariables . tco opts
30replaceIdent :: (Data d) => Ident -> JS -> d -> d
31replaceIdent var1 js = everywhere (mkT replace)
32 where
33 replace (JSVar var2) | var1 == var2 = js
34 replace other = other
36replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d
37replaceIdents vars = everywhere (mkT replace)
38 where
39 replace v@(JSVar var) = fromMaybe v $ lookup var vars
40 replace other = other
42isReassigned :: (Data d) => Ident -> d -> Bool
43isReassigned var1 = everything (||) (mkQ False check)
44 where
45 check :: JS -> Bool
46 check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True
47 check _ = False
49isUsed :: (Data d) => Ident -> d -> Bool
50isUsed var1 = everything (||) (mkQ False check)
51 where
52 check :: JS -> Bool
53 check (JSVar var2) | var1 == var2 = True
54 check (JSAssignment target _) | var1 == targetVariable target = True
55 check _ = False
56 targetVariable :: JSAssignment -> Ident
57 targetVariable (JSAssignVariable var) = var
58 targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
60shouldInline :: JS -> Bool
61shouldInline (JSVar _) = True
62shouldInline (JSNumericLiteral _) = True
63shouldInline (JSStringLiteral _) = True
64shouldInline (JSBooleanLiteral _) = True
65shouldInline (JSAccessor _ val) = shouldInline val
66shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
67shouldInline _ = False
69inlineVariables :: JS -> JS
70inlineVariables = everywhere (mkT removeFromBlock)
71 where
72 removeFromBlock :: JS -> JS
73 removeFromBlock (JSBlock sts) = JSBlock (go sts)
74 removeFromBlock js = js
75 go :: [JS] -> [JS]
76 go [] = []
77 go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)
78 go (s:sts) = s : go sts
80removeUnusedVariables :: JS -> JS
81removeUnusedVariables = everywhere (mkT removeFromBlock)
82 where
83 removeFromBlock :: JS -> JS
84 removeFromBlock (JSBlock sts) = JSBlock (go sts)
85 removeFromBlock js = js
86 go :: [JS] -> [JS]
87 go [] = []
88 go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
89 go (s:sts) = s : go sts
91etaConvert :: JS -> JS
92etaConvert = everywhere (mkT convert)
93 where
94 convert :: JS -> JS
95 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])
96 | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)
97 convert js = js
99unThunk :: JS -> JS
100unThunk = everywhere (mkT convert)
101 where
102 convert :: JS -> JS
103 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
104 convert js = js
106tco :: Options -> JS -> JS
107tco opts | optionsTco opts = tco'
108 | otherwise = id
110tco' :: JS -> JS
111tco' = everywhere (mkT convert)
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"
120 convert :: JS -> JS
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')))
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)
134 isTailCall :: Ident -> JS -> Bool
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
148 toLoop :: Ident -> [Ident] -> JS -> JS
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