git.iko.soy/rowtype-yoga/purescript-native
on 0ca3eaa help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Optimize.hs
120 lines 3.8 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 = tco opts . removeUnusedVariables . unThunk . etaConvert . inlineVariables
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 convert :: JS -> JS
114 convert (JSVariableIntroduction name (Just (JSFunction Nothing args body)))
115 | isTailCall name body = (JSVariableIntroduction name (Just (JSFunction Nothing args (toLoop name args body))))
116 convert js = js
117 isTailCall :: Ident -> JS -> Bool
118 isTailCall _ _ = False
119 toLoop :: Ident -> [Ident] -> JS -> JS
120 toLoop = undefined