@@ -1,458 +0,0 @@
1−-----------------------------------------------------------------------------
3−-- Module : Language.PureScript.Optimize
4−-- Copyright : (c) Phil Freeman 2013
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
12−-- This module optimizes code in the simplified-Javascript intermediate representation.
14−-- The following optimizations are supported:
16−-- * Collapsing nested blocks
18−-- * Tail call elimination
20−-- * Inlining of (>>=) and ret for the Eff monad
22−-- * Removal of unused variables
24−-- * Removal of unnecessary thunks
28−-- * Inlining variables
30−-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
32−-- * Inlining primitive Javascript operators
34−-----------------------------------------------------------------------------
36−module Language.PureScript.CodeGen.Optimize (
41−import Data.List (nub)
42−import Data.Maybe (fromJust, isJust, fromMaybe)
45−import Language.PureScript.Names
46−import Language.PureScript.CodeGen.JS.AST
47−import Language.PureScript.Options
48−import Language.PureScript.CodeGen.Common (identToJs)
51−-- Apply a series of optimizer passes to simplified Javascript code
53−optimize :: Options -> JS -> JS
54−optimize opts | optionsNoOptimizations opts = id
55− | otherwise = untilFixedPoint $ applyAll
56− [ collapseNestedBlocks
59− , removeUnusedVariables
63− , inlineOperator "$" $ \f x -> JSApp f [x]
64− , inlineOperator "#" $ \x f -> JSApp f [x]
65− , inlineOperator "!!" $ flip JSIndexer
66− , inlineOperator "++" $ JSBinary Add
67− , inlineCommonOperators ]
69−applyAll :: [a -> a] -> a -> a
72−untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
73−untilFixedPoint f = go
75− go a = let a' = f a in
76− if a' == a then a' else go a'
78−replaceIdent :: (Data d) => String -> JS -> d -> d
79−replaceIdent var1 js = everywhere (mkT replace)
81− replace (JSVar var2) | var1 == var2 = js
82− replace other = other
84−replaceIdents :: (Data d) => [(String, JS)] -> d -> d
85−replaceIdents vars = everywhere (mkT replace)
87− replace v@(JSVar var) = fromMaybe v $ lookup var vars
88− replace other = other
90−isReassigned :: (Data d) => String -> d -> Bool
91−isReassigned var1 = everything (||) (mkQ False check)
94− check (JSFunction _ args _) | var1 `elem` args = True
95− check (JSVariableIntroduction arg _) | var1 == arg = True
96− check (JSAssignment (JSVar arg) _) | var1 == arg = True
99−isRebound :: (Data d) => JS -> d -> Bool
100−isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js)
102− variablesOf (JSVar var) = [var]
105−isUsed :: (Data d) => String -> d -> Bool
106−isUsed var1 = everything (||) (mkQ False check)
109− check (JSVar var2) | var1 == var2 = True
110− check (JSAssignment target _) | var1 == targetVariable target = True
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"
119−isUpdated :: (Data d) => String -> d -> Bool
120−isUpdated var1 = everything (||) (mkQ False check)
123− check (JSAssignment target _) | var1 == targetVariable target = True
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
135−removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
136−removeFromBlock go (JSBlock sts) = JSBlock (go sts)
137−removeFromBlock _ js = js
139−inlineVariables :: JS -> JS
140−inlineVariables = everywhere (mkT $ removeFromBlock 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
149−removeUnusedVariables :: JS -> JS
150−removeUnusedVariables = everywhere (mkT $ removeFromBlock go)
154− go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
155− go (s:sts) = s : go sts
157−etaConvert :: JS -> JS
158−etaConvert = everywhere (mkT convert)
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)
169−unThunk = everywhere (mkT convert)
172− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
175−tco :: Options -> JS -> JS
176−tco opts | optionsTco opts = tco'
180−tco' = everywhere (mkT convert)
184− tcoVar :: String -> String
185− tcoVar arg = "__tco_" ++ arg
186− copyVar :: String -> String
187− copyVar arg = "__copy_" ++ arg
189− convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
191− (argss, body', replace) = collectAllFunctionArgs [] id fn
193− _ | isTailCall name body' ->
195− allArgs = reverse $ concat argss
197− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
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 =
213− numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
214− numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
215− numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
218− && numSelfCalls == numSelfCallsInTailPosition
219− && numSelfCallsUnderFunctions == 0
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 ]) ]
235− loopify (JSReturn ret) | isSelfCall ident ret =
237− allArgumentValues = concat $ collectSelfCallArgs [] ret
239− JSBlock $ zipWith (\val arg ->
240− JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
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
253−magicDo :: Options -> JS -> JS
254−magicDo opts | optionsMagicDo opts = inlineST . magicDo'
258−-- Inline type class dictionaries for >>= and return for the Eff monad
262−-- Prelude[">>="](dict)(m1)(function(x) {
274−magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
276− -- The name of the function block which is added to denote a do block
278− -- Desugar monomorphic calls to >>= and return for the Eff monad
281− convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
283− convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
284− JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
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 []) ]
289− convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =
290− JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
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
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
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
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
318− -- Remove __do function applications which remain after desugaring
320− undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
324−-- Inline functions in the ST module
327−inlineST = everywhere (mkT convertBlock)
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 =
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)
361− isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]
363− -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
364− findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
366− isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]
367− isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]
369− -- Find all uses of a variable
370− appearingIn ref = everything (++) (mkQ [] isVar)
372− isVar e@(JSVar v) | v == ref = [e]
374− -- Convert a JS value to a String if it is a JSVar
375− toVar (JSVar v) = Just v
378−collapseNestedBlocks :: JS -> JS
379−collapseNestedBlocks = everywhere (mkT collapse)
381− collapse :: JS -> JS
382− collapse (JSBlock sts) = JSBlock (concatMap go sts)
385− go (JSBlock sts) = sts
388−inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS
389−inlineOperator op f = everywhere (mkT convert)
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
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
407− , binary "ordNumber" "<" LessThan
408− , binary "ordNumber" ">" GreaterThan
409− , binary "ordNumber" "<=" LessThanOrEqualTo
410− , binary "ordNumber" ">=" GreaterThanOrEqualTo
412− , binary "eqNumber" "==" EqualTo
413− , binary "eqNumber" "/=" NotEqualTo
414− , binary "eqString" "==" EqualTo
415− , binary "eqString" "/=" NotEqualTo
416− , binary "eqBoolean" "==" EqualTo
417− , binary "eqBoolean" "/=" NotEqualTo
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
427− , binary "boolLikeBoolean" "&&" And
428− , binary "boolLikeBoolean" "||" Or
429− , unary "boolLikeBoolean" "not" Not
432− binary :: String -> String -> BinaryOperator -> JS -> JS
433− binary dictName opString op = everywhere (mkT convert)
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
441− binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
442− binaryFunction dictName fnName op = everywhere (mkT convert)
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
449− unary :: String -> String -> UnaryOperator -> JS -> JS
450− unary dictName fnName op = everywhere (mkT convert)
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
457− isOpDict dictName (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
458− isOpDict _ _ = False