git.iko.soy/rowtype-yoga/purescript-native
on 03362b2 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Optimize.hs
194 lines 6.9 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 =
29 collapseNestedBlocks
30 . tco opts
31 . removeUnusedVariables
32 . unThunk
33 . etaConvert
34 . inlineVariables
36replaceIdent :: (Data d) => Ident -> JS -> d -> d
37replaceIdent var1 js = everywhere (mkT replace)
38 where
39 replace (JSVar var2) | var1 == var2 = js
40 replace other = other
42replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d
43replaceIdents vars = everywhere (mkT replace)
44 where
45 replace v@(JSVar var) = fromMaybe v $ lookup var vars
46 replace other = other
48isReassigned :: (Data d) => Ident -> d -> Bool
49isReassigned var1 = everything (||) (mkQ False check)
50 where
51 check :: JS -> Bool
52 check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True
53 check _ = False
55isUsed :: (Data d) => Ident -> d -> Bool
56isUsed var1 = everything (||) (mkQ False check)
57 where
58 check :: JS -> Bool
59 check (JSVar var2) | var1 == var2 = True
60 check (JSAssignment target _) | var1 == targetVariable target = True
61 check _ = False
62 targetVariable :: JSAssignment -> Ident
63 targetVariable (JSAssignVariable var) = var
64 targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
66shouldInline :: JS -> Bool
67shouldInline (JSVar _) = True
68shouldInline (JSNumericLiteral _) = True
69shouldInline (JSStringLiteral _) = True
70shouldInline (JSBooleanLiteral _) = True
71shouldInline (JSAccessor _ val) = shouldInline val
72shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
73shouldInline _ = False
75inlineVariables :: JS -> JS
76inlineVariables = everywhere (mkT removeFromBlock)
77 where
78 removeFromBlock :: JS -> JS
79 removeFromBlock (JSBlock sts) = JSBlock (go sts)
80 removeFromBlock js = js
81 go :: [JS] -> [JS]
82 go [] = []
83 go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)
84 go (s:sts) = s : go sts
86removeUnusedVariables :: JS -> JS
87removeUnusedVariables = everywhere (mkT removeFromBlock)
88 where
89 removeFromBlock :: JS -> JS
90 removeFromBlock (JSBlock sts) = JSBlock (go sts)
91 removeFromBlock js = js
92 go :: [JS] -> [JS]
93 go [] = []
94 go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
95 go (s:sts) = s : go sts
97etaConvert :: JS -> JS
98etaConvert = everywhere (mkT convert)
99 where
100 convert :: JS -> JS
101 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])
102 | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)
103 convert js = js
105unThunk :: JS -> JS
106unThunk = everywhere (mkT convert)
107 where
108 convert :: JS -> JS
109 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
110 convert js = js
112tco :: Options -> JS -> JS
113tco opts | optionsTco opts = tco'
114 | otherwise = id
116tco' :: JS -> JS
117tco' = everywhere (mkT convert)
118 where
119 tcoLabel :: String
120 tcoLabel = "tco"
121 tcoVar :: Ident -> Ident
122 tcoVar (Ident arg) = Ident $ "__tco_" ++ arg
123 tcoVar _ = error "Invalid name in tcoVar"
124 convert :: JS -> JS
125 convert js@(JSVariableIntroduction name (Just fn@(JSFunction Nothing _ _))) =
126 let
127 (argss, body', replace) = collectAllFunctionArgs [] id fn
128 in case () of
129 _ | isTailCall name body' ->
130 let
131 allArgs = reverse $ concat argss
132 in
133 JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
134 | otherwise -> js
135 convert js = js
136 collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
137 collectAllFunctionArgs allArgs f (JSFunction Nothing args (JSBlock (body@(JSReturn _):_))) =
138 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing args (JSBlock [b]))) body
139 collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [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)))
143 collectAllFunctionArgs allArgs f body = (allArgs, body, f)
144 isTailCall :: Ident -> JS -> Bool
145 isTailCall ident js =
146 let
147 numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
148 numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
149 numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
150 in
151 numSelfCalls > 0
152 && numSelfCalls == numSelfCallsInTailPosition
153 && numSelfCallsUnderFunctions == 0
154 where
155 countSelfCalls :: JS -> Int
156 countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
157 countSelfCalls _ = 0
158 countSelfCallsInTailPosition :: JS -> Int
159 countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
160 countSelfCallsInTailPosition _ = 0
161 countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
162 countSelfCallsUnderFunctions _ = 0
163 toLoop :: Ident -> [Ident] -> JS -> JS
164 toLoop ident allArgs js = JSBlock
165 [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
166 where
167 loopify :: JS -> JS
168 loopify (JSReturn ret) | isSelfCall ident ret =
169 let
170 allArgumentValues = concat $ collectSelfCallArgs [] ret
171 in
172 JSBlock $ zipWith (\val arg ->
173 JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
174 ++ map (\arg ->
175 JSAssignment (JSAssignVariable arg) (JSVar (tcoVar arg))) allArgs
176 ++ [ JSContinue tcoLabel ]
177 loopify other = other
178 collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
179 collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
180 collectSelfCallArgs allArgumentValues _ = allArgumentValues
181 isSelfCall :: Ident -> JS -> Bool
182 isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
183 isSelfCall ident (JSApp fn _) = isSelfCall ident fn
184 isSelfCall _ _ = False
186collapseNestedBlocks :: JS -> JS
187collapseNestedBlocks = 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]