git.iko.soy/rowtype-yoga/purescript-native
on b3741cd 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.List
20import Data.Graph
21import Data.Maybe (mapMaybe)
23import Language.PureScript.Names
24import Language.PureScript.Declarations
26-- |
27-- Eliminate all declarations which are not a transitive dependency of the entry point module
28--
29eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]
30eliminateDeadCode entryPoints ms = map go ms
31 where
32 go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')
33 where
34 ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds
35 exps' = mapMaybe (filterExport ds') exps
36 go _ = error "Exports should have been elaborated in name desugaring"
37 declarations = concatMap declarationsByModule ms
38 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
39 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
41 filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef
42 filterExport decls r@(TypeRef name _) | (any $ typeExists name) decls = Just r
43 filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r
44 filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r
45 filterExport _ _ = Nothing
47 valueExists :: Ident -> Declaration -> Bool
48 valueExists name (ValueDeclaration name' _ _ _ _) = name == name'
49 valueExists name (ExternDeclaration _ name' _ _) = name == name'
50 valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls
51 valueExists name (PositionedDeclaration _ d) = valueExists name d
52 valueExists _ _ = False
54 typeExists :: ProperName -> Declaration -> Bool
55 typeExists name (DataDeclaration name' _ _) = name == name'
56 typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls
57 typeExists name (PositionedDeclaration _ d) = typeExists name d
58 typeExists _ _ = False
60type Key = (ModuleName, Either Ident ProperName)
62declarationsByModule :: Module -> [(Key, [Key])]
63declarationsByModule (Module moduleName ds _) = concatMap go ds
64 where
65 go :: Declaration -> [(Key, [Key])]
66 go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
67 go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
68 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
69 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
70 go (DataBindingGroupDeclaration ds') = concatMap go ds'
71 go (PositionedDeclaration _ d) = go d
72 go _ = []
74dependencies :: ModuleName -> Declaration -> [Key]
75dependencies moduleName =
76 let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])
77 in nub . f
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