24826e7 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Dead code elimination #190

commit24826e71e6ac8219bb3f8f703fa0c5aabc9e7dcc authorPhil Freeman <paf31@cantab.net> dateWed 12 Feb 2014, 13:44 (13 years ago) parente01b631

16 files changed+132−25

compare with golang

unifiedsplit

examples/passing/Operators.purs+2−1

@@ -15,6 +15,7 @@ module Operators1 where

1515module Operators2 where

1616

1717 import Prelude

18+ import Operators1 ((@@))

1819

1920 test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n

2021 test1 x y z = x * y + z x y

@@ -40,7 +41,7 @@ module Operators2 where

4041

4142 test7 = "Hello" <> "World!"

4243

43− test9 = Operators1.foo Operators1.@@ "Hello World"

44+ test9 = Operators1.foo @@ "Hello World"

4445

4546 test10 = "Hello" `Operators1.bar` "World"

4647

prelude/tests/Eff.purs+1−1

@@ -58,4 +58,4 @@ module Main where

5858

5959import Tests

6060

61−main = test9 {}

61+main = test5 {}

prelude/tests/build.sh+1−1

@@ -1,2 +1,2 @@

1−psc ../prelude.purs Eff.purs --magic-do --run-main --no-prelude -o Eff.js

1+psc ../prelude.purs Eff.purs --magic-do --tco --run-main --no-prelude --entry-point Main -o Eff.js

psc/Main.hs+5−1

@@ -98,8 +98,12 @@ browserNamespace :: Term String

9898browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])

9999 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }

100100

101+entryPoint :: Term (Maybe String)

102+entryPoint = value $ opt Nothing $ (optInfo [ "entry-point" ])

103+ { optDoc = "Specify the module which is the entry point. All code which is not a transitive dependency of this module will be removed." }

104+

101105options :: Term P.Options

102−options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace

106+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> entryPoint

103107

104108stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])

105109stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles

psci/Main.hs+1−1

@@ -35,7 +35,7 @@ getPreludeFilename :: IO FilePath

3535getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs"

3636

3737options :: P.Options

38−options = P.Options True False True True True "PS"

38+options = P.Options True False True True True "PS" Nothing

3939

4040completion :: [P.Module] -> CompletionFunc IO

4141completion ms = completeWord Nothing " \t\n\r" findCompletions

purescript.cabal+1

@@ -27,6 +27,7 @@ library

2727 Language.PureScript.Types

2828 Language.PureScript.Values

2929 Language.PureScript.Scope

30+ Language.PureScript.DeadCodeElimination

3031 Language.PureScript.Sugar

3132 Language.PureScript.ModuleDependencies

3233 Language.PureScript.Sugar.CaseDeclarations

src/Language/PureScript.hs+8−2

@@ -27,8 +27,10 @@ import Language.PureScript.Pretty as P

2727import Language.PureScript.Sugar as P

2828import Language.PureScript.Options as P

2929import Language.PureScript.ModuleDependencies as P

30+import Language.PureScript.DeadCodeElimination as P

3031

3132import Data.List (intercalate)

33+import Data.Maybe (mapMaybe)

3234import Control.Monad (when, forM)

3335import Control.Monad.State.Lazy

3436import Control.Applicative ((<$>))

@@ -47,6 +49,8 @@ import qualified Data.Map as M

4749--

4850-- * Regroup values to take into account new value dependencies introduced by elaboration

4951--

52+-- * Eliminate dead code

53+--

5054-- * Generate Javascript, and perform optimization passes.

5155--

5256-- * Pretty-print the generated Javascript

@@ -59,8 +63,10 @@ compile opts ms = do

5963 modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })

6064 Module moduleName <$> typeCheckAll (ModuleName moduleName) decls

6165 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

62− let js = map (flip (moduleToJs opts) env) $ regrouped

63− let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped

66+ let entryPoint = optionsEntryPoint opts

67+ let elim = maybe regrouped (\ep -> eliminateDeadCode env ep regrouped) entryPoint

68+ let js = mapMaybe (flip (moduleToJs opts) env) elim

69+ let exts = intercalate "\n" . map (flip moduleToPs env) $ elim

6470 js' <- case () of

6571 _ | optionsRunMain opts -> do

6672 when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $

src/Language/PureScript/CodeGen/JS.hs+6−4

@@ -51,11 +51,13 @@ import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)

5151-- Generate code in the simplified Javascript intermediate representation for all declarations in a

5252-- module.

5353--

54−moduleToJs :: Options -> Module -> Environment -> JS

54+moduleToJs :: Options -> Module -> Environment -> Maybe JS

5555moduleToJs opts (Module pname@(ProperName name) decls) env =

56− JSAssignment (JSAccessor name (JSVar "_ps")) $ JSApp (JSFunction Nothing ["module"]

57− (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))

58− [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]

56+ case jsDecls of

57+ [] -> Nothing

58+ _ -> Just $ JSAssignment (JSAccessor name (JSVar "_ps")) $

59+ JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))

60+ [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]

5961 where

6062 jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (decls))

6163

src/Language/PureScript/CodeGen/Optimize.hs+1−1

@@ -382,7 +382,7 @@ inlineCommonOperators = applyAll

382382 isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True

383383 where

384384 Right (Ident dictName) = mkDictionaryValueName

385− (ModuleName (ProperName "Prelude"))

385+ (ModuleName (ProperName "Prim"))

386386 (Qualified (Just (ModuleName (ProperName "Prelude"))) (ProperName className))

387387 ty

388388 isOpDict _ _ _ = False

src/Language/PureScript/DeadCodeElimination.hsnew file+76

@@ -0,0 +1,76 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.DeadCodeElimination

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.DeadCodeElimination (

16+ eliminateDeadCode

17+) where

18+

19+import Data.Data

20+import Data.List

21+import Data.Graph

22+import Data.Generics

23+import Data.Maybe (mapMaybe)

24+

25+import Language.PureScript.Names

26+import Language.PureScript.Values

27+import Language.PureScript.Declarations

28+import Language.PureScript.TypeChecker.Monad

29+

30+-- |

31+-- Eliminate all declarations which are not a transitive dependency of the entry point module

32+--

33+eliminateDeadCode :: Environment -> String -> [Module] -> [Module]

34+eliminateDeadCode env entryPoint ms =

35+ let declarations = concatMap (declarationsByModule env) ms

36+ (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

37+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn == entryPoint) $ declarations

38+ in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (ModuleName moduleName) graph vertexFor entryPointVertices) ds)

39+

40+type Key = (ModuleName, Either Ident ProperName)

41+

42+declarationsByModule :: Environment -> Module -> [(Key, [Key])]

43+declarationsByModule env (Module moduleName ds) = concatMap go $ ds

44+ where

45+ go :: Declaration -> [(Key, [Key])]

46+ go d@(ValueDeclaration name _ _ _) = [((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)]

47+ go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((ModuleName moduleName, Right name), [])) dctors

48+ go (ExternDeclaration _ name _ _) = [((ModuleName moduleName, Left name), [])]

49+ go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)) names

50+ go (DataBindingGroupDeclaration ds) = concatMap go ds

51+ go _ = []

52+

53+dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]

54+dependencies env moduleName = nub . everything (++) (mkQ [] values)

55+ where

56+ values :: Value -> [Key]

57+ values (Var ident) = let (mn, name) = canonicalize moduleName env ident in [(mn, Left name)]

58+ values (Constructor pn) = let (mn, name) = canonicalizeDataConstructor moduleName env pn in [(mn, Right name)]

59+ values _ = []

60+

61+isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool

62+isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =

63+ let Just v' = vertexFor (moduleName, Left name)

64+ in any (\v -> path graph v v') entryPointVertices

65+isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =

66+ any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)

67+ in any (\v -> path graph v v') entryPointVertices) dctors

68+isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =

69+ let Just v' = vertexFor (moduleName, Left name)

70+ in any (\v -> path graph v v') entryPointVertices

71+isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =

72+ any (\(name, _) -> let Just v' = vertexFor (moduleName, Left name)

73+ in any (\v -> path graph v v') entryPointVertices) ds

74+isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =

75+ any (isUsed moduleName graph vertexFor entryPointVertices) ds

76+isUsed _ _ _ _ _ = True

src/Language/PureScript/Names.hs+13−1

@@ -18,6 +18,7 @@

1818module Language.PureScript.Names where

1919

2020import Data.Data

21+import Data.Function (on)

2122

2223-- |

2324-- Names for value identifiers

@@ -34,13 +35,24 @@ data Ident

3435 -- |

3536 -- An escaped name

3637 --

37− | Escaped String deriving (Eq, Ord, Data, Typeable)

38+ | Escaped String deriving (Data, Typeable)

3839

3940instance Show Ident where

4041 show (Ident s) = s

4142 show (Op op) = '(':op ++ ")"

4243 show (Escaped s) = s

4344

45+instance Eq Ident where

46+ Ident s1 == Ident s2 = s1 == s2

47+ Op s1 == Op s2 = s1 == s2

48+ Escaped s1 == Escaped s2 = s1 == s2

49+ Ident s1 == Escaped s2 = s1 == s2

50+ Escaped s1 == Ident s2 = s1 == s2

51+ _ == _ = False

52+

53+instance Ord Ident where

54+ compare = compare `on` show

55+

4456-- |

4557-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

4658--

src/Language/PureScript/Options.hs+5−1

@@ -44,10 +44,14 @@ data Options = Options {

4444 -- browser.

4545 --

4646 , optionsBrowserNamespace :: String

47+ -- |

48+ -- The entry point module, for dead code elimination

49+ --

50+ , optionsEntryPoint :: Maybe String

4751 } deriving Show

4852

4953-- |

5054-- Default compiler options

5155--

5256defaultOptions :: Options

53−defaultOptions = Options False False False False False "PS"

57+defaultOptions = Options False False False False False "PS" Nothing

src/Language/PureScript/Parser/Common.hs+1−1

@@ -319,7 +319,7 @@ buildPostfixParser fs first = do

319319-- Parse an identifier in backticks or an operator

320320--

321321parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)

322−parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operator)

322+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> Qualified Nothing <$> (Op <$> operator)

323323

324324-- |

325325-- Mark the current indentation level

src/Language/PureScript/Sugar/Operators.hs+5−4

@@ -58,7 +58,11 @@ removeParens val = val

5858customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]

5959customOperatorTable fixities =

6060 let

61− applyUserOp name t1 t2 = App (App (Var name) t1) t2

61+ -- We make the assumption here that infix operators are not qualified. The parser currently enforces this.

62+ -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name

63+ -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to

64+ -- make sure that the generated code is correct.

65+ applyUserOp (Qualified _ name) t1 t2 = App (App (Var (Qualified Nothing name)) t1) t2

6266 userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities

6367 sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps

6468 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

@@ -108,6 +112,3 @@ collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do

108112 collectFixities (M.union m' m) moduleName rest

109113collectFixities m moduleName (_:ds) = collectFixities m moduleName ds

110114

111−globalOp :: String -> Qualified Ident

112−globalOp = Qualified Nothing . Op

113−

src/Language/PureScript/TypeChecker/Monad.hs+5−5

@@ -224,11 +224,11 @@ canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types

224224-- |

225225-- Canonicalize a data constructor by resolving any aliases introduced by module imports

226226--

227−canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, Ident)

228−canonicalizeDataConstructor _ _ (Qualified (Just mn) i) = (mn, Ident $ show i)

229−canonicalizeDataConstructor mn env (Qualified Nothing i) = case (mn, i) `M.lookup` dataConstructors env of

230− Just (_, Alias mn' i') -> (mn', i')

231− _ -> (mn, Ident $ show i)

227+canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)

228+canonicalizeDataConstructor _ _ (Qualified (Just mn) pn) = (mn, pn)

229+canonicalizeDataConstructor mn env (Qualified Nothing pn) = case (mn, pn) `M.lookup` dataConstructors env of

230+ Just (_, Alias mn' (Ident pn')) -> (mn', ProperName pn')

231+ _ -> (mn, pn)

232232

233233-- |

234234-- State required for type checking:

tests/Main.hs+1−1

@@ -66,7 +66,7 @@ assertCompiles :: FilePath -> IO ()

6666assertCompiles inputFile = do

6767 putStrLn $ "assert " ++ inputFile ++ " compiles successfully"

6868 prelude <- preludeFilename

69− assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True }) [prelude, inputFile] $ either (return . Just) $ \js -> do

69+ assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True, P.optionsEntryPoint = Just "Main" }) [prelude, inputFile] $ either (return . Just) $ \js -> do

7070 args <- getArgs

7171 if "--run-js" `elem` args

7272 then do