git.iko.soy/rowtype-yoga/purescript-native
on bef7806 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/DeadCodeElimination.hs
105 lines 5.0 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.DeadCodeElimination
4-- Copyright : (c) 2014 Phil Freeman
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15module Language.PureScript.DeadCodeElimination (
16 eliminateDeadCode
17) where
19import Data.Data
20import Data.List
21import Data.Graph
22import Data.Generics
23import Data.Maybe (mapMaybe)
25import Language.PureScript.Names
26import Language.PureScript.Declarations
28-- |
29-- Eliminate all declarations which are not a transitive dependency of the entry point module
30--
31eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]
32eliminateDeadCode entryPoints ms = map go ms
33 where
34 go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')
35 where
36 ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds
37 exps' = mapMaybe (filterExport ds') exps
38 go _ = error "Exports should have been elaborated in name desugaring"
39 declarations = concatMap declarationsByModule ms
40 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
41 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
43 filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef
44 filterExport decls r@(TypeRef name _) | (any $ typeExists name) decls = Just r
45 filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r
46 filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r
47 filterExport _ _ = Nothing
49 valueExists :: Ident -> Declaration -> Bool
50 valueExists name (ValueDeclaration name' _ _ _ _) = name == name'
51 valueExists name (ExternDeclaration _ name' _ _) = name == name'
52 valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls
53 valueExists name (PositionedDeclaration _ d) = valueExists name d
54 valueExists _ _ = False
56 typeExists :: ProperName -> Declaration -> Bool
57 typeExists name (DataDeclaration name' _ _) = name == name'
58 typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls
59 typeExists name (PositionedDeclaration _ d) = typeExists name d
60 typeExists _ _ = False
62type Key = (ModuleName, Either Ident ProperName)
64declarationsByModule :: Module -> [(Key, [Key])]
65declarationsByModule (Module moduleName ds _) = concatMap go ds
66 where
67 go :: Declaration -> [(Key, [Key])]
68 go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
69 go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
70 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
71 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
72 go (DataBindingGroupDeclaration ds') = concatMap go ds'
73 go (PositionedDeclaration _ d) = go d
74 go _ = []
76dependencies :: (Data d) => ModuleName -> d -> [Key]
77dependencies moduleName = nub . everything (++) (mkQ [] values)
78 where
79 values :: Value -> [Key]
80 values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
81 values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
82 values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
83 values _ = []
85isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
86isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _ _) =
87 let Just v' = vertexFor (moduleName, Left name)
88 in any (\v -> path graph v v') entryPointVertices
89isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =
90 let Just v' = vertexFor (moduleName, Left $ Op name)
91 in any (\v -> path graph v v') entryPointVertices
92isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =
93 any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)
94 in any (\v -> path graph v v') entryPointVertices) dctors
95isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =
96 let Just v' = vertexFor (moduleName, Left name)
97 in any (\v -> path graph v v') entryPointVertices
98isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =
99 any (\(name, _, _) -> let Just v' = vertexFor (moduleName, Left name)
100 in any (\v -> path graph v v') entryPointVertices) ds
101isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
102 any (isUsed moduleName graph vertexFor entryPointVertices) ds
103isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =
104 isUsed moduleName graph vertexFor entryPointVertices d
105isUsed _ _ _ _ _ = True