@@ -1,458 +0,0 @@
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−-- This module optimizes code in the simplified-Javascript intermediate representation.
13−--
14−-- The following optimizations are supported:
15−--
16−-- * Collapsing nested blocks
17−--
18−-- * Tail call elimination
19−--
20−-- * Inlining of (>>=) and ret for the Eff monad
21−--
22−-- * Removal of unused variables
23−--
24−-- * Removal of unnecessary thunks
25−--
26−-- * Eta conversion
27−--
28−-- * Inlining variables
29−--
30−-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
31−--
32−-- * Inlining primitive Javascript operators
33−--
34−-----------------------------------------------------------------------------
35−
36−module Language.PureScript.CodeGen.Optimize (
37− optimize
38−) where
39−
40−import Data.Data
41−import Data.List (nub)
42−import Data.Maybe (fromJust, isJust, fromMaybe)
43−import Data.Generics
44−
45−import Language.PureScript.Names
46−import Language.PureScript.CodeGen.JS.AST
47−import Language.PureScript.Options
48−import Language.PureScript.CodeGen.Common (identToJs)
49−
50−-- |
51−-- Apply a series of optimizer passes to simplified Javascript code
52−--
53−optimize :: Options -> JS -> JS
54−optimize opts | optionsNoOptimizations opts = id
55− | otherwise = untilFixedPoint $ applyAll
56− [ collapseNestedBlocks
57− , tco opts
58− , magicDo opts
59− , removeUnusedVariables
60− , unThunk
61− , etaConvert
62− , inlineVariables
63− , inlineOperator "$" $ \f x -> JSApp f [x]
64− , inlineOperator "#" $ \x f -> JSApp f [x]
65− , inlineOperator "!!" $ flip JSIndexer
66− , inlineOperator "++" $ JSBinary Add
67− , inlineCommonOperators ]
68−
69−applyAll :: [a -> a] -> a -> a
70−applyAll = foldl1 (.)
71−
72−untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
73−untilFixedPoint f = go
74− where
75− go a = let a' = f a in
76− if a' == a then a' else go a'
77−
78−replaceIdent :: (Data d) => String -> JS -> d -> d
79−replaceIdent var1 js = everywhere (mkT replace)
80− where
81− replace (JSVar var2) | var1 == var2 = js
82− replace other = other
83−
84−replaceIdents :: (Data d) => [(String, JS)] -> d -> d
85−replaceIdents vars = everywhere (mkT replace)
86− where
87− replace v@(JSVar var) = fromMaybe v $ lookup var vars
88− replace other = other
89−
90−isReassigned :: (Data d) => String -> d -> Bool
91−isReassigned var1 = everything (||) (mkQ False check)
92− where
93− check :: JS -> Bool
94− check (JSFunction _ args _) | var1 `elem` args = True
95− check (JSVariableIntroduction arg _) | var1 == arg = True
96− check (JSAssignment (JSVar arg) _) | var1 == arg = True
97− check _ = False
98−
99−isRebound :: (Data d) => JS -> d -> Bool
100−isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js)
101− where
102− variablesOf (JSVar var) = [var]
103− variablesOf _ = []
104−
105−isUsed :: (Data d) => String -> d -> Bool
106−isUsed var1 = everything (||) (mkQ False check)
107− where
108− check :: JS -> Bool
109− check (JSVar var2) | var1 == var2 = True
110− check (JSAssignment target _) | var1 == targetVariable target = True
111− check _ = False
112−
113−targetVariable :: JS -> String
114−targetVariable (JSVar var) = var
115−targetVariable (JSAccessor _ tgt) = targetVariable tgt
116−targetVariable (JSIndexer _ tgt) = targetVariable tgt
117−targetVariable _ = error "Invalid argument to targetVariable"
118−
119−isUpdated :: (Data d) => String -> d -> Bool
120−isUpdated var1 = everything (||) (mkQ False check)
121− where
122− check :: JS -> Bool
123− check (JSAssignment target _) | var1 == targetVariable target = True
124− check _ = False
125−
126−shouldInline :: JS -> Bool
127−shouldInline (JSVar _) = True
128−shouldInline (JSNumericLiteral _) = True
129−shouldInline (JSStringLiteral _) = True
130−shouldInline (JSBooleanLiteral _) = True
131−shouldInline (JSAccessor _ val) = shouldInline val
132−shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
133−shouldInline _ = False
134−
135−removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
136−removeFromBlock go (JSBlock sts) = JSBlock (go sts)
137−removeFromBlock _ js = js
138−
139−inlineVariables :: JS -> JS
140−inlineVariables = everywhere (mkT $ removeFromBlock go)
141− where
142− go :: [JS] -> [JS]
143− go [] = []
144− go (JSVariableIntroduction var (Just js) : sts)
145− | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =
146− go (replaceIdent var js sts)
147− go (s:sts) = s : go sts
148−
149−removeUnusedVariables :: JS -> JS
150−removeUnusedVariables = everywhere (mkT $ removeFromBlock go)
151− where
152− go :: [JS] -> [JS]
153− go [] = []
154− go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
155− go (s:sts) = s : go sts
156−
157−etaConvert :: JS -> JS
158−etaConvert = everywhere (mkT convert)
159− where
160− convert :: JS -> JS
161− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
162− | all shouldInline args &&
163− not (any (`isRebound` block) (map JSVar idents)) &&
164− not (any (`isRebound` block) args)
165− = JSBlock (replaceIdents (zip idents args) body)
166− convert js = js
167−
168−unThunk :: JS -> JS
169−unThunk = everywhere (mkT convert)
170− where
171− convert :: JS -> JS
172− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
173− convert js = js
174−
175−tco :: Options -> JS -> JS
176−tco opts | optionsTco opts = tco'
177− | otherwise = id
178−
179−tco' :: JS -> JS
180−tco' = everywhere (mkT convert)
181− where
182− tcoLabel :: String
183− tcoLabel = "tco"
184− tcoVar :: String -> String
185− tcoVar arg = "__tco_" ++ arg
186− copyVar :: String -> String
187− copyVar arg = "__copy_" ++ arg
188− convert :: JS -> JS
189− convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
190− let
191− (argss, body', replace) = collectAllFunctionArgs [] id fn
192− in case () of
193− _ | isTailCall name body' ->
194− let
195− allArgs = reverse $ concat argss
196− in
197− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
198− | otherwise -> js
199− convert js = js
200− collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
201− collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
202− collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
203− collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
204− (args : allArgs, body, f . JSFunction ident (map copyVar args))
205− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
206− collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
207− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
208− (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
209− collectAllFunctionArgs allArgs f body = (allArgs, body, f)
210− isTailCall :: String -> JS -> Bool
211− isTailCall ident js =
212− let
213− numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
214− numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
215− numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
216− in
217− numSelfCalls > 0
218− && numSelfCalls == numSelfCallsInTailPosition
219− && numSelfCallsUnderFunctions == 0
220− where
221− countSelfCalls :: JS -> Int
222− countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
223− countSelfCalls _ = 0
224− countSelfCallsInTailPosition :: JS -> Int
225− countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
226− countSelfCallsInTailPosition _ = 0
227− countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
228− countSelfCallsUnderFunctions _ = 0
229− toLoop :: String -> [String] -> JS -> JS
230− toLoop ident allArgs js = JSBlock $
231− map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
232− [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
233− where
234− loopify :: JS -> JS
235− loopify (JSReturn ret) | isSelfCall ident ret =
236− let
237− allArgumentValues = concat $ collectSelfCallArgs [] ret
238− in
239− JSBlock $ zipWith (\val arg ->
240− JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
241− ++ map (\arg ->
242− JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
243− ++ [ JSContinue tcoLabel ]
244− loopify other = other
245− collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
246− collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
247− collectSelfCallArgs allArgumentValues _ = allArgumentValues
248− isSelfCall :: String -> JS -> Bool
249− isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
250− isSelfCall ident (JSApp fn _) = isSelfCall ident fn
251− isSelfCall _ _ = False
252−
253−magicDo :: Options -> JS -> JS
254−magicDo opts | optionsMagicDo opts = inlineST . magicDo'
255− | otherwise = id
256−
257−-- |
258−-- Inline type class dictionaries for >>= and return for the Eff monad
259−--
260−-- E.g.
261−--
262−-- Prelude[">>="](dict)(m1)(function(x) {
263−-- return ...;
264−-- })
265−--
266−-- becomes
267−--
268−-- function __do {
269−-- var x = m1();
270−-- ...
271−-- }
272−--
273−magicDo' :: JS -> JS
274−magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
275− where
276− -- The name of the function block which is added to denote a do block
277− fnName = "__do"
278− -- Desugar monomorphic calls to >>= and return for the Eff monad
279− convert :: JS -> JS
280− -- Desugar return
281− convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
282− -- Desugae >>
283− convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
284− JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
285− -- Desugar >>=
286− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
287− JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
288− -- Desugar untilE
289− convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =
290− JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
291− -- Desugar whileE
292− convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =
293− JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
294− convert other = other
295− -- Check if an expression represents a monomorphic call to >>= for the Eff monad
296− isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
297− isBind _ = False
298− -- Check if an expression represents a monomorphic call to return for the Eff monad
299− isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
300− isReturn _ = False
301− -- Check if an expression represents the polymorphic >>= function
302− isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True
303− isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True
304− isBindPoly _ = False
305− -- Check if an expression represents the polymorphic return function
306− isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
307− isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
308− isRetPoly _ = False
309− -- Check if an expression represents a function in the Ef module
310− isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True
311− isEffFunc _ _ = False
312− -- The name of the type class dictionary for the Monad Eff instance
313− effDictName = "monadEff"
314− -- Check if an expression represents the Monad Eff dictionary
315− isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
316− isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
317− isEffDict _ = False
318− -- Remove __do function applications which remain after desugaring
319− undo :: JS -> JS
320− undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
321− undo other = other
322−
323−-- |
324−-- Inline functions in the ST module
325−--
326−inlineST :: JS -> JS
327−inlineST = everywhere (mkT convertBlock)
328− where
329− -- Look for runST blocks and inline the STRefs there.
330− -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
331− -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
332− convertBlock (JSApp f [arg]) | isSTFunc "runST" f || isSTFunc "runSTArray" f =
333− let refs = nub . findSTRefsIn $ arg
334− usages = findAllSTUsagesIn arg
335− allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
336− localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
337− in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
338− convertBlock other = other
339− -- Convert a block in a safe way, preserving object wrappers of references,
340− -- or in a more aggressive way, turning wrappers into local variables depending on the
341− -- agg(ressive) parameter.
342− convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =
343− if agg then arg else JSObjectLiteral [("value", arg)]
344− convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =
345− if agg then ref else JSAccessor "value" ref
346− convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =
347− if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg
348− convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =
349− if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])
350− convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =
351− JSIndexer i arr
352− convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =
353− JSAssignment (JSIndexer i arr) val
354− convert _ other = other
355− -- Check if an expression represents a function in the ST module
356− isSTFunc name (JSAccessor name' (JSAccessor "Control_Monad_ST" (JSVar "_ps"))) | name == name' = True
357− isSTFunc _ _ = False
358− -- Find all ST Refs initialized in this block
359− findSTRefsIn = everything (++) (mkQ [] isSTRef)
360− where
361− isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]
362− isSTRef _ = []
363− -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
364− findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
365− where
366− isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]
367− isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]
368− isSTUsage _ = []
369− -- Find all uses of a variable
370− appearingIn ref = everything (++) (mkQ [] isVar)
371− where
372− isVar e@(JSVar v) | v == ref = [e]
373− isVar _ = []
374− -- Convert a JS value to a String if it is a JSVar
375− toVar (JSVar v) = Just v
376− toVar _ = Nothing
377−
378−collapseNestedBlocks :: JS -> JS
379−collapseNestedBlocks = everywhere (mkT collapse)
380− where
381− collapse :: JS -> JS
382− collapse (JSBlock sts) = JSBlock (concatMap go sts)
383− collapse js = js
384− go :: JS -> [JS]
385− go (JSBlock sts) = sts
386− go s = [s]
387−
388−inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS
389−inlineOperator op f = everywhere (mkT convert)
390− where
391− convert :: JS -> JS
392− convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
393− convert other = other
394− isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True
395− isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True
396− isOp _ = False
397−
398−inlineCommonOperators :: JS -> JS
399−inlineCommonOperators = applyAll
400− [ binary "numNumber" "+" Add
401− , binary "numNumber" "-" Subtract
402− , binary "numNumber" "*" Multiply
403− , binary "numNumber" "/" Divide
404− , binary "numNumber" "%" Modulus
405− , unary "numNumber" "negate" Negate
406−
407− , binary "ordNumber" "<" LessThan
408− , binary "ordNumber" ">" GreaterThan
409− , binary "ordNumber" "<=" LessThanOrEqualTo
410− , binary "ordNumber" ">=" GreaterThanOrEqualTo
411−
412− , binary "eqNumber" "==" EqualTo
413− , binary "eqNumber" "/=" NotEqualTo
414− , binary "eqString" "==" EqualTo
415− , binary "eqString" "/=" NotEqualTo
416− , binary "eqBoolean" "==" EqualTo
417− , binary "eqBoolean" "/=" NotEqualTo
418−
419− , binaryFunction "bitsNumber" "shl" ShiftLeft
420− , binaryFunction "bitsNumber" "shr" ShiftRight
421− , binaryFunction "bitsNumber" "zshr" ZeroFillShiftRight
422− , binary "bitsNumber" "&" BitwiseAnd
423− , binary "bitsNumber" "|" BitwiseOr
424− , binary "bitsNumber" "^" BitwiseXor
425− , unary "bitsNumber" "complement" BitwiseNot
426−
427− , binary "boolLikeBoolean" "&&" And
428− , binary "boolLikeBoolean" "||" Or
429− , unary "boolLikeBoolean" "not" Not
430− ]
431− where
432− binary :: String -> String -> BinaryOperator -> JS -> JS
433− binary dictName opString op = everywhere (mkT convert)
434− where
435− convert :: JS -> JS
436− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
437− convert other = other
438− isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True
439− isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
440− isOp _ = False
441− binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
442− binaryFunction dictName fnName op = everywhere (mkT convert)
443− where
444− convert :: JS -> JS
445− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
446− convert other = other
447− isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True
448− isOp _ = False
449− unary :: String -> String -> UnaryOperator -> JS -> JS
450− unary dictName fnName op = everywhere (mkT convert)
451− where
452− convert :: JS -> JS
453− convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
454− convert other = other
455− isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True
456− isOp _ = False
457− isOpDict dictName (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
458− isOpDict _ _ = False