summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-02-12 21:45:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-12 21:45:00 (GMT)
commit000e7234cea556c39a8b58530676dde3a59d90aa (patch)
tree3eef3f077821aeeb26217d64f93ad579b21d7b03
parent52ee81fd0a89698afa62a30cfbf67d58ec0450e8 (diff)
version 0.3.140.3.14
-rw-r--r--psc/Main.hs6
-rw-r--r--psci/Main.hs2
-rw-r--r--purescript.cabal3
-rw-r--r--src/Language/PureScript.hs10
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs10
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs36
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs76
-rw-r--r--src/Language/PureScript/Names.hs14
-rw-r--r--src/Language/PureScript/Options.hs6
-rw-r--r--src/Language/PureScript/Parser/Common.hs2
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs9
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs10
-rw-r--r--tests/Main.hs2
13 files changed, 151 insertions, 35 deletions
diff --git a/psc/Main.hs b/psc/Main.hs
index f331f75..df1eb13 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -98,8 +98,12 @@ browserNamespace :: Term String
browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
{ optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
+entryPoint :: Term (Maybe String)
+entryPoint = value $ opt Nothing $ (optInfo [ "entry-point" ])
+ { optDoc = "Specify the module which is the entry point. All code which is not a transitive dependency of this module will be removed." }
+
options :: Term P.Options
-options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace
+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> entryPoint
stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
diff --git a/psci/Main.hs b/psci/Main.hs
index 65fe327..ea30a47 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -35,7 +35,7 @@ getPreludeFilename :: IO FilePath
getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs"
options :: P.Options
-options = P.Options True False True True True "PS"
+options = P.Options True False True True True "PS" Nothing
completion :: [P.Module] -> CompletionFunc IO
completion ms = completeWord Nothing " \t\n\r" findCompletions
diff --git a/purescript.cabal b/purescript.cabal
index 6a68dd6..9474c4f 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.3.13.1
+version: 0.3.14
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -27,6 +27,7 @@ library
Language.PureScript.Types
Language.PureScript.Values
Language.PureScript.Scope
+ Language.PureScript.DeadCodeElimination
Language.PureScript.Sugar
Language.PureScript.ModuleDependencies
Language.PureScript.Sugar.CaseDeclarations
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index d16132e..0b90583 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -27,8 +27,10 @@ import Language.PureScript.Pretty as P
import Language.PureScript.Sugar as P
import Language.PureScript.Options as P
import Language.PureScript.ModuleDependencies as P
+import Language.PureScript.DeadCodeElimination as P
import Data.List (intercalate)
+import Data.Maybe (mapMaybe)
import Control.Monad (when, forM)
import Control.Monad.State.Lazy
import Control.Applicative ((<$>))
@@ -47,6 +49,8 @@ import qualified Data.Map as M
--
-- * Regroup values to take into account new value dependencies introduced by elaboration
--
+-- * Eliminate dead code
+--
-- * Generate Javascript, and perform optimization passes.
--
-- * Pretty-print the generated Javascript
@@ -59,8 +63,10 @@ compile opts ms = do
modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })
Module moduleName <$> typeCheckAll (ModuleName moduleName) decls
regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
- let js = map (flip (moduleToJs opts) env) $ regrouped
- let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped
+ let entryPoint = optionsEntryPoint opts
+ let elim = maybe regrouped (\ep -> eliminateDeadCode env ep regrouped) entryPoint
+ let js = mapMaybe (flip (moduleToJs opts) env) elim
+ let exts = intercalate "\n" . map (flip moduleToPs env) $ elim
js' <- case () of
_ | optionsRunMain opts -> do
when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 0923da2..43e8aa4 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -51,11 +51,13 @@ import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
-- module.
--
-moduleToJs :: Options -> Module -> Environment -> JS
+moduleToJs :: Options -> Module -> Environment -> Maybe JS
moduleToJs opts (Module pname@(ProperName name) decls) env =
- JSAssignment (JSAccessor name (JSVar "_ps")) $ JSApp (JSFunction Nothing ["module"]
- (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))
- [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]
+ case jsDecls of
+ [] -> Nothing
+ _ -> Just $ JSAssignment (JSAccessor name (JSVar "_ps")) $
+ JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))
+ [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]
where
jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (decls))
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index 368d0c9..63d77cc 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -261,6 +261,7 @@ magicDo' :: JS -> JS
magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
where
fnName = "__do"
+
convert :: JS -> JS
convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
@@ -268,24 +269,33 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
convert other = other
+
isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
isBind _ = False
+
isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
isReturn _ = False
- isBindPoly (JSAccessor prop (JSVar "Prelude")) | prop == identToJs (Op ">>=") = True
- isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSVar "Prelude")) = True
+
+ isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True
+ isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True
isBindPoly _ = False
- isRetPoly (JSAccessor "$return" (JSVar "Prelude")) = True
+
+ isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
+ isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
isRetPoly _ = False
+
prelude = ModuleName (ProperName "Prelude")
effModule = ModuleName (ProperName "Eff")
+
Right (Ident effDictName) = mkDictionaryValueName
effModule
(Qualified (Just prelude) (ProperName "Monad"))
(TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))
- isEffDict (JSVar ident) | ident == effDictName = True
- isEffDict (JSAccessor prop (JSVar "Eff")) | prop == effDictName = True
+
+ isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
+ isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
isEffDict _ = False
+
undo :: JS -> JS
undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
undo other = other
@@ -306,8 +316,8 @@ inlineOperator op f = everywhere (mkT convert)
convert :: JS -> JS
convert (JSApp (JSApp op [x]) [y]) | isOp op = f x y
convert other = other
- isOp (JSAccessor longForm (JSVar "Prelude")) | longForm == identToJs (Op op) = True
- isOp (JSIndexer (JSStringLiteral op') (JSVar "Prelude")) | op == op' = True
+ isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True
+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True
isOp _ = False
inlineCommonOperators :: JS -> JS
@@ -350,8 +360,8 @@ inlineCommonOperators = applyAll
convert :: JS -> JS
convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
convert other = other
- isOp (JSAccessor longForm (JSVar "Prelude")) | longForm == identToJs (Op opString) = True
- isOp (JSIndexer (JSStringLiteral op') (JSVar "Prelude")) | opString == op' = True
+ isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar ps))) | longForm == identToJs (Op opString) = True
+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
isOp _ = False
binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS
binaryFunction fnName className classTy op = everywhere (mkT convert)
@@ -359,7 +369,7 @@ inlineCommonOperators = applyAll
convert :: JS -> JS
convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
convert other = other
- isOp (JSAccessor fnName' (JSVar "Prelude")) | fnName == fnName' = True
+ isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True
isOp _ = False
unary :: String -> String -> Type -> UnaryOperator -> JS -> JS
unary fnName className classTy op = everywhere (mkT convert)
@@ -367,12 +377,12 @@ inlineCommonOperators = applyAll
convert :: JS -> JS
convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict className classTy dict = JSUnary op x
convert other = other
- isOp (JSAccessor fnName' (JSVar "Prelude")) | fnName' == fnName = True
+ isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True
isOp _ = False
- isOpDict className ty (JSAccessor prop (JSVar "Prelude")) | prop == dictName = True
+ isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
where
Right (Ident dictName) = mkDictionaryValueName
- (ModuleName (ProperName "Prelude"))
+ (ModuleName (ProperName "Prim"))
(Qualified (Just (ModuleName (ProperName "Prelude"))) (ProperName className))
ty
isOpDict _ _ _ = False
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
new file mode 100644
index 0000000..1c97756
--- /dev/null
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -0,0 +1,76 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.DeadCodeElimination
+-- Copyright : (c) 2014 Phil Freeman
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.DeadCodeElimination (
+ eliminateDeadCode
+) where
+
+import Data.Data
+import Data.List
+import Data.Graph
+import Data.Generics
+import Data.Maybe (mapMaybe)
+
+import Language.PureScript.Names
+import Language.PureScript.Values
+import Language.PureScript.Declarations
+import Language.PureScript.TypeChecker.Monad
+
+-- |
+-- Eliminate all declarations which are not a transitive dependency of the entry point module
+--
+eliminateDeadCode :: Environment -> String -> [Module] -> [Module]
+eliminateDeadCode env entryPoint ms =
+ let declarations = concatMap (declarationsByModule env) ms
+ (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn == entryPoint) $ declarations
+ in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (ModuleName moduleName) graph vertexFor entryPointVertices) ds)
+
+type Key = (ModuleName, Either Ident ProperName)
+
+declarationsByModule :: Environment -> Module -> [(Key, [Key])]
+declarationsByModule env (Module moduleName ds) = concatMap go $ ds
+ where
+ go :: Declaration -> [(Key, [Key])]
+ go d@(ValueDeclaration name _ _ _) = [((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)]
+ go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((ModuleName moduleName, Right name), [])) dctors
+ go (ExternDeclaration _ name _ _) = [((ModuleName moduleName, Left name), [])]
+ go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)) names
+ go (DataBindingGroupDeclaration ds) = concatMap go ds
+ go _ = []
+
+dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]
+dependencies env moduleName = nub . everything (++) (mkQ [] values)
+ where
+ values :: Value -> [Key]
+ values (Var ident) = let (mn, name) = canonicalize moduleName env ident in [(mn, Left name)]
+ values (Constructor pn) = let (mn, name) = canonicalizeDataConstructor moduleName env pn in [(mn, Right name)]
+ values _ = []
+
+isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
+isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =
+ let Just v' = vertexFor (moduleName, Left name)
+ in any (\v -> path graph v v') entryPointVertices
+isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =
+ any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)
+ in any (\v -> path graph v v') entryPointVertices) dctors
+isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =
+ let Just v' = vertexFor (moduleName, Left name)
+ in any (\v -> path graph v v') entryPointVertices
+isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =
+ any (\(name, _) -> let Just v' = vertexFor (moduleName, Left name)
+ in any (\v -> path graph v v') entryPointVertices) ds
+isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
+ any (isUsed moduleName graph vertexFor entryPointVertices) ds
+isUsed _ _ _ _ _ = True
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 4519e53..e232909 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -18,6 +18,7 @@
module Language.PureScript.Names where
import Data.Data
+import Data.Function (on)
-- |
-- Names for value identifiers
@@ -34,13 +35,24 @@ data Ident
-- |
-- An escaped name
--
- | Escaped String deriving (Eq, Ord, Data, Typeable)
+ | Escaped String deriving (Data, Typeable)
instance Show Ident where
show (Ident s) = s
show (Op op) = '(':op ++ ")"
show (Escaped s) = s
+instance Eq Ident where
+ Ident s1 == Ident s2 = s1 == s2
+ Op s1 == Op s2 = s1 == s2
+ Escaped s1 == Escaped s2 = s1 == s2
+ Ident s1 == Escaped s2 = s1 == s2
+ Escaped s1 == Ident s2 = s1 == s2
+ _ == _ = False
+
+instance Ord Ident where
+ compare = compare `on` show
+
-- |
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
--
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 09b86fb..7c7e86c 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -44,10 +44,14 @@ data Options = Options {
-- browser.
--
, optionsBrowserNamespace :: String
+ -- |
+ -- The entry point module, for dead code elimination
+ --
+ , optionsEntryPoint :: Maybe String
} deriving Show
-- |
-- Default compiler options
--
defaultOptions :: Options
-defaultOptions = Options False False False False False "PS"
+defaultOptions = Options False False False False False "PS" Nothing
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index fa0d722..7ea2711 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -319,7 +319,7 @@ buildPostfixParser fs first = do
-- Parse an identifier in backticks or an operator
--
parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
-parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operator)
+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> Qualified Nothing <$> (Op <$> operator)
-- |
-- Mark the current indentation level
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index d76928c..a103b25 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -58,7 +58,11 @@ removeParens val = val
customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
customOperatorTable fixities =
let
- applyUserOp name t1 t2 = App (App (Var name) t1) t2
+ -- We make the assumption here that infix operators are not qualified. The parser currently enforces this.
+ -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name
+ -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to
+ -- make sure that the generated code is correct.
+ applyUserOp (Qualified _ name) t1 t2 = App (App (Var (Qualified Nothing name)) t1) t2
userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps
groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
@@ -108,6 +112,3 @@ collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do
collectFixities (M.union m' m) moduleName rest
collectFixities m moduleName (_:ds) = collectFixities m moduleName ds
-globalOp :: String -> Qualified Ident
-globalOp = Qualified Nothing . Op
-
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 48fc6ee..2d35e92 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -224,11 +224,11 @@ canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types
-- |
-- Canonicalize a data constructor by resolving any aliases introduced by module imports
--
-canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, Ident)
-canonicalizeDataConstructor _ _ (Qualified (Just mn) i) = (mn, Ident $ show i)
-canonicalizeDataConstructor mn env (Qualified Nothing i) = case (mn, i) `M.lookup` dataConstructors env of
- Just (_, Alias mn' i') -> (mn', i')
- _ -> (mn, Ident $ show i)
+canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
+canonicalizeDataConstructor _ _ (Qualified (Just mn) pn) = (mn, pn)
+canonicalizeDataConstructor mn env (Qualified Nothing pn) = case (mn, pn) `M.lookup` dataConstructors env of
+ Just (_, Alias mn' (Ident pn')) -> (mn', ProperName pn')
+ _ -> (mn, pn)
-- |
-- State required for type checking:
diff --git a/tests/Main.hs b/tests/Main.hs
index d9ec999..c8e4d69 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -66,7 +66,7 @@ assertCompiles :: FilePath -> IO ()
assertCompiles inputFile = do
putStrLn $ "assert " ++ inputFile ++ " compiles successfully"
prelude <- preludeFilename
- assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True }) [prelude, inputFile] $ either (return . Just) $ \js -> do
+ assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True, P.optionsEntryPoint = Just "Main" }) [prelude, inputFile] $ either (return . Just) $ \js -> do
args <- getArgs
if "--run-js" `elem` args
then do