git.iko.soy/rowtype-yoga/purescript-native
on fa07667 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Optimize.hs
198 lines 7.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 =
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 copyVar :: Ident -> Ident
125 copyVar (Ident arg) = Ident $ "__copy_" ++ arg
126 copyVar _ = error "Invalid name in copyVar"
127 convert :: JS -> JS
128 convert js@(JSVariableIntroduction name (Just fn@(JSFunction Nothing _ _))) =
129 let
130 (argss, body', replace) = collectAllFunctionArgs [] id fn
131 in case () of
132 _ | isTailCall name body' ->
133 let
134 allArgs = reverse $ concat argss
135 in
136 JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
137 | otherwise -> js
138 convert js = js
139 collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
140 collectAllFunctionArgs allArgs f (JSFunction Nothing args (JSBlock (body@(JSReturn _):_))) =
141 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing (map copyVar args) (JSBlock [b]))) body
142 collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) =
143 collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction Nothing (map copyVar args) (JSBlock [b])))) body
144 collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args body@(JSBlock _))) =
145 (args : allArgs, body, \b -> f (JSReturn (JSFunction Nothing (map copyVar args) b)))
146 collectAllFunctionArgs allArgs f body = (allArgs, body, f)
147 isTailCall :: Ident -> JS -> Bool
148 isTailCall ident js =
149 let
150 numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
151 numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
152 numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
153 in
154 numSelfCalls > 0
155 && numSelfCalls == numSelfCallsInTailPosition
156 && numSelfCallsUnderFunctions == 0
157 where
158 countSelfCalls :: JS -> Int
159 countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
160 countSelfCalls _ = 0
161 countSelfCallsInTailPosition :: JS -> Int
162 countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
163 countSelfCallsInTailPosition _ = 0
164 countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
165 countSelfCallsUnderFunctions _ = 0
166 toLoop :: Ident -> [Ident] -> JS -> JS
167 toLoop ident allArgs js = JSBlock $
168 map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
169 [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
170 where
171 loopify :: JS -> JS
172 loopify (JSReturn ret) | isSelfCall ident ret =
173 let
174 allArgumentValues = concat $ collectSelfCallArgs [] ret
175 in
176 JSBlock $ zipWith (\val arg ->
177 JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
178 ++ map (\arg ->
179 JSAssignment (JSAssignVariable arg) (JSVar (tcoVar arg))) allArgs
180 ++ [ JSContinue tcoLabel ]
181 loopify other = other
182 collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
183 collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
184 collectSelfCallArgs allArgumentValues _ = allArgumentValues
185 isSelfCall :: Ident -> JS -> Bool
186 isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
187 isSelfCall ident (JSApp fn _) = isSelfCall ident fn
188 isSelfCall _ _ = False
190collapseNestedBlocks :: JS -> JS
191collapseNestedBlocks = everywhere (mkT collapse)
192 where
193 collapse :: JS -> JS
194 collapse (JSBlock sts) = JSBlock (concatMap go sts)
195 collapse js = js
196 go :: JS -> [JS]
197 go (JSBlock sts) = sts
198 go s = [s]