git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Basic Javascript optimizations
36bae69Phil Freeman
purescript.cabal+16−15
compare with golang
unifiedsplit
@@ -12,21 +12,22 @@ description: A small compile-to-JS language with extensible records and type-saf
12category: Language
12category: Language
13author: Phil Freeman <paf31@cantab.net>
13author: Phil Freeman <paf31@cantab.net>
14data-dir: ""
14data-dir: ""
15−
15+
16library
16library
17 build-depends: base >=4 && <5, syb -any, cmdtheline -any,
17 build-depends: base >=4 && <5, syb -any, cmdtheline -any,
18 containers -any, mtl -any, transformers -any, parsec -any,
18 containers -any, mtl -any, transformers -any, parsec -any,
19 utf8-string -any
19 utf8-string -any
20− exposed-modules: Language.PureScript.Pretty.JS
20+ exposed-modules: Language.PureScript.Optimize
21− Language.PureScript.CodeGen.JS.AST Main Language.PureScript
21+ Language.PureScript.Pretty.JS Language.PureScript.CodeGen.JS.AST
22− Language.PureScript.Declarations Language.PureScript.Names
22+ Main Language.PureScript Language.PureScript.Declarations
23+ Language.PureScript.Names Language.PureScript.Types
23− Language.PureScript.Types Language.PureScript.Values
24+ Language.PureScript.Values Language.PureScript.Kinds
24− Language.PureScript.Kinds Language.PureScript.Pretty
25+ Language.PureScript.Pretty Language.PureScript.Pretty.Common
25− Language.PureScript.Pretty.Common Language.PureScript.Pretty.Values
26+ Language.PureScript.Pretty.Values Language.PureScript.Pretty.Types
26− Language.PureScript.Pretty.Types Language.PureScript.Pretty.Kinds
27+ Language.PureScript.Pretty.Kinds Language.PureScript.CodeGen
27− Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
28+ Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS
28− Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.Monad
29+ Language.PureScript.CodeGen.Monad Language.PureScript.Parser
29− Language.PureScript.Parser Language.PureScript.Parser.Common
30+ Language.PureScript.Parser.Common
30 Language.PureScript.Parser.Declarations
31 Language.PureScript.Parser.Declarations
31 Language.PureScript.Parser.Types Language.PureScript.Parser.Values
32 Language.PureScript.Parser.Types Language.PureScript.Parser.Values
32 Language.PureScript.Parser.State Language.PureScript.Parser.Kinds
33 Language.PureScript.Parser.State Language.PureScript.Parser.Kinds
@@ -38,7 +39,7 @@ library
38 exposed: True
39 exposed: True
39 buildable: True
40 buildable: True
40 hs-source-dirs: src
41 hs-source-dirs: src
41−
42+
42executable psc
43executable psc
43 build-depends: base >=4 && <5, cmdtheline -any, containers -any,
44 build-depends: base >=4 && <5, cmdtheline -any, containers -any,
44 mtl -any, transformers -any, parsec -any, utf8-string -any,
45 mtl -any, transformers -any, parsec -any, utf8-string -any,
@@ -46,8 +47,8 @@ executable psc
46 main-is: Main.hs
47 main-is: Main.hs
47 buildable: True
48 buildable: True
48 hs-source-dirs: src
49 hs-source-dirs: src
49− other-modules:
50+ other-modules: Language.PureScript.Optimize
50−
51+
51test-suite tests
52test-suite tests
52 build-depends: base >=4 && <5, syb -any, directory -any,
53 build-depends: base >=4 && <5, syb -any, directory -any,
53 filepath -any, containers -any, mtl -any, transformers -any,
54 filepath -any, containers -any, mtl -any, transformers -any,
@@ -55,4 +56,4 @@ test-suite tests
55 type: exitcode-stdio-1.0
56 type: exitcode-stdio-1.0
56 main-is: Main.hs
57 main-is: Main.hs
57 buildable: True
58 buildable: True
58− hs-source-dirs: tests
59+ hs-source-dirs: tests
src/Language/PureScript.hs+3
@@ -23,4 +23,7 @@ import Language.PureScript.Parser as P
23import Language.PureScript.CodeGen as P
23import Language.PureScript.CodeGen as P
24import Language.PureScript.TypeChecker as P
24import Language.PureScript.TypeChecker as P
25import Language.PureScript.Pretty as P
25import Language.PureScript.Pretty as P
26+import Language.PureScript.Optimize as P
27+
28+
26
29
src/Language/PureScript/CodeGen/JS.hs+11−11
@@ -76,21 +76,21 @@ bindersToJs binders val = do
76binderToJs :: String -> [JS] -> Binder -> Gen [JS]
76binderToJs :: String -> [JS] -> Binder -> Gen [JS]
77binderToJs varName done NullBinder = return done
77binderToJs varName done NullBinder = return done
78binderToJs varName done (StringBinder str) =
78binderToJs varName done (StringBinder str) =
79− return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) done Nothing]
79+ return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
80binderToJs varName done (NumberBinder num) =
80binderToJs varName done (NumberBinder num) =
81− return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) done Nothing]
81+ return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]
82binderToJs varName done (BooleanBinder True) =
82binderToJs varName done (BooleanBinder True) =
83− return [JSIfElse (JSVar (Ident varName)) done Nothing]
83+ return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]
84binderToJs varName done (BooleanBinder False) =
84binderToJs varName done (BooleanBinder False) =
85− return [JSIfElse (JSUnary Not (JSVar (Ident varName))) done Nothing]
85+ return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]
86binderToJs varName done (VarBinder ident) =
86binderToJs varName done (VarBinder ident) =
87 return (JSVariableIntroduction ident (JSVar (Ident varName)) : done)
87 return (JSVariableIntroduction ident (JSVar (Ident varName)) : done)
88binderToJs varName done (NullaryBinder ctor) =
88binderToJs varName done (NullaryBinder ctor) =
89− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) done Nothing]
89+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock done) Nothing]
90binderToJs varName done (UnaryBinder ctor b) = do
90binderToJs varName done (UnaryBinder ctor b) = do
91 value <- fresh
91 value <- fresh
92 js <- binderToJs value done b
92 js <- binderToJs value done b
93− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSVariableIntroduction (Ident value) (JSAccessor "value" (JSVar (Ident varName))) : js) Nothing]
93+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock (JSVariableIntroduction (Ident value) (JSAccessor "value" (JSVar (Ident varName))) : js)) Nothing]
94binderToJs varName done (ObjectBinder bs) = go done bs
94binderToJs varName done (ObjectBinder bs) = go done bs
95 where
95 where
96 go :: [JS] -> [(String, Binder)] -> Gen [JS]
96 go :: [JS] -> [(String, Binder)] -> Gen [JS]
@@ -102,7 +102,7 @@ binderToJs varName done (ObjectBinder bs) = go done bs
102 return (JSVariableIntroduction (Ident propVar) (JSAccessor prop (JSVar (Ident varName))) : js)
102 return (JSVariableIntroduction (Ident propVar) (JSAccessor prop (JSVar (Ident varName))) : js)
103binderToJs varName done (ArrayBinder bs rest) = do
103binderToJs varName done (ArrayBinder bs rest) = do
104 js <- go done rest 0 bs
104 js <- go done rest 0 bs
105− return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) js Nothing]
105+ return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
106 where
106 where
107 cmp :: BinaryOperator
107 cmp :: BinaryOperator
108 cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest
108 cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest
@@ -122,18 +122,18 @@ binderToJs varName done (NamedBinder ident binder) = do
122 return (JSVariableIntroduction ident (JSVar (Ident varName)) : js)
122 return (JSVariableIntroduction ident (JSVar (Ident varName)) : js)
123binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
123binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
124 where
124 where
125− done' = [JSIfElse (valueToJs cond) done Nothing]
125+ done' = [JSIfElse (valueToJs cond) (JSBlock done) Nothing]
126
126
127statementToJs :: Statement -> JS
127statementToJs :: Statement -> JS
128statementToJs (VariableIntroduction ident value) = JSVariableIntroduction ident (valueToJs value)
128statementToJs (VariableIntroduction ident value) = JSVariableIntroduction ident (valueToJs value)
129statementToJs (Assignment target value) = JSAssignment target (valueToJs value)
129statementToJs (Assignment target value) = JSAssignment target (valueToJs value)
130−statementToJs (While cond sts) = JSWhile (valueToJs cond) (map statementToJs sts)
130+statementToJs (While cond sts) = JSWhile (valueToJs cond) (JSBlock (map statementToJs sts))
131−statementToJs (For ident start end sts) = JSFor ident (valueToJs start) (valueToJs end) (map statementToJs sts)
131+statementToJs (For ident start end sts) = JSFor ident (valueToJs start) (valueToJs end) (JSBlock (map statementToJs sts))
132statementToJs (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs arr)) [JSFunction Nothing [ident] (JSBlock (map statementToJs sts))]
132statementToJs (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs arr)) [JSFunction Nothing [ident] (JSBlock (map statementToJs sts))]
133statementToJs (If ifst) = ifToJs ifst
133statementToJs (If ifst) = ifToJs ifst
134 where
134 where
135 ifToJs :: IfStatement -> JS
135 ifToJs :: IfStatement -> JS
136− ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs cond) (map statementToJs thens) (fmap elseToJs elses)
136+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs cond) (JSBlock (map statementToJs thens)) (fmap elseToJs elses)
137 elseToJs :: ElseStatement -> JS
137 elseToJs :: ElseStatement -> JS
138 elseToJs (Else sts) = JSBlock (map statementToJs sts)
138 elseToJs (Else sts) = JSBlock (map statementToJs sts)
139 elseToJs (ElseIf ifst) = ifToJs ifst
139 elseToJs (ElseIf ifst) = ifToJs ifst
src/Language/PureScript/CodeGen/JS/AST.hs+3−3
@@ -38,8 +38,8 @@ data JS
38 | JSBlock [JS]
38 | JSBlock [JS]
39 | JSVariableIntroduction Ident JS
39 | JSVariableIntroduction Ident JS
40 | JSAssignment Ident JS
40 | JSAssignment Ident JS
41− | JSWhile JS [JS]
41+ | JSWhile JS JS
42− | JSFor Ident JS JS [JS]
42+ | JSFor Ident JS JS JS
43− | JSIfElse JS [JS] (Maybe JS)
43+ | JSIfElse JS JS (Maybe JS)
44 | JSReturn JS
44 | JSReturn JS
45 | JSThrow JS deriving (Show, Data, Typeable)
45 | JSThrow JS deriving (Show, Data, Typeable)
src/Language/PureScript/Optimize.hsnew file+55
@@ -0,0 +1,55 @@
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+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Optimize (
16+ optimize
17+) where
18+
19+import Data.Data
20+import Data.Generics
21+
22+import Language.PureScript.Names
23+import Language.PureScript.CodeGen.JS.AST
24+
25+optimize :: JS -> JS
26+optimize = etaConvert . inlineVariables
27+
28+replaceIdent :: (Data d) => Ident -> JS -> d -> d
29+replaceIdent var1 js = everywhere (mkT replace)
30+ where
31+ replace (JSVar var2) | var1 == var2 = js
32+ replace js = js
33+
34+shouldInline :: JS -> Bool
35+shouldInline (JSVar _) = True
36+shouldInline (JSAccessor _ val) = shouldInline val
37+shouldInline _ = False
38+
39+inlineVariables :: JS -> JS
40+inlineVariables = everywhere (mkT removeFromBlock)
41+ where
42+ removeFromBlock :: JS -> JS
43+ removeFromBlock (JSBlock sts) = JSBlock (go sts)
44+ removeFromBlock js = js
45+ go :: [JS] -> [JS]
46+ go [] = []
47+ go (JSVariableIntroduction var js : sts) | shouldInline js = go (replaceIdent var js sts)
48+ go (s:sts) = s : go sts
49+
50+etaConvert :: JS -> JS
51+etaConvert = everywhere (mkT convert)
52+ where
53+ convert :: JS -> JS
54+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [ident] (JSBlock body)) [arg])]) | shouldInline arg = JSBlock (replaceIdent ident arg body)
55+ convert js = js
src/Language/PureScript/Pretty/JS.hs+6−6
@@ -40,16 +40,16 @@ literals = Pattern $ A.Kleisli match
40 match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ " = " ++ prettyPrintJS value
40 match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ " = " ++ prettyPrintJS value
41 match (JSAssignment target value) = Just $ identToJs target ++ " = " ++ prettyPrintJS value
41 match (JSAssignment target value) = Just $ identToJs target ++ " = " ++ prettyPrintJS value
42 match (JSWhile cond sts) = Just $ "while ("
42 match (JSWhile cond sts) = Just $ "while ("
43− ++ prettyPrintJS cond ++ ") { "
43+ ++ prettyPrintJS cond ++ ") "
44− ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
44+ ++ prettyPrintJS sts
45 match (JSFor ident start end sts) = Just $ "for ("
45 match (JSFor ident start end sts) = Just $ "for ("
46 ++ identToJs ident ++ " = " ++ prettyPrintJS start ++ "; "
46 ++ identToJs ident ++ " = " ++ prettyPrintJS start ++ "; "
47 ++ identToJs ident ++ " < " ++ prettyPrintJS end ++ "; "
47 ++ identToJs ident ++ " < " ++ prettyPrintJS end ++ "; "
48− ++ identToJs ident ++ "++) { "
48+ ++ identToJs ident ++ "++) "
49− ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
49+ ++ prettyPrintJS sts
50 match (JSIfElse cond thens elses) = Just $ "if ("
50 match (JSIfElse cond thens elses) = Just $ "if ("
51− ++ prettyPrintJS cond ++ ") { "
51+ ++ prettyPrintJS cond ++ ") "
52− ++ intercalate "; " (map prettyPrintJS thens) ++ " }"
52+ ++ prettyPrintJS thens
53 ++ maybe "" ((" else " ++) . prettyPrintJS) elses
53 ++ maybe "" ((" else " ++) . prettyPrintJS) elses
54 match (JSReturn value) = Just $ "return " ++ prettyPrintJS value
54 match (JSReturn value) = Just $ "return " ++ prettyPrintJS value
55 match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
55 match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
src/Main.hs+1−1
@@ -40,7 +40,7 @@ compile inputFiles outputFile externsFile = do
40 U.putStrLn typeError
40 U.putStrLn typeError
41 exitFailure
41 exitFailure
42 Right (_, env) -> do
42 Right (_, env) -> do
43− let js = intercalate "; " . map prettyPrintJS . concat . mapMaybe (declToJs) $ decls
43+ let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs) $ decls
44 case outputFile of
44 case outputFile of
45 Just path -> U.writeFile path js
45 Just path -> U.writeFile path js
46 Nothing -> U.putStrLn js
46 Nothing -> U.putStrLn js